    {-# LANGUAGE OverloadedStrings #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.XmlRpc.Client
    -- Copyright   :  (c) Bjorn Bringert 2003
    -- License     :  BSD-style
    --
    -- Maintainer  :  bjorn@bringert.net
    -- Stability   :  experimental
    -- Portability :  non-portable (requires extensions and non-portable libraries)
    --
    -- This module contains the client functionality of XML-RPC.
    -- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.
    --
    -- A simple client application:
    --
    -- > import Network.XmlRpc.Client
    -- >
    -- > server = "http://localhost/~bjorn/cgi-bin/simple_server"
    -- >
    -- > add :: String -> Int -> Int -> IO Int
    -- > add url = remote url "examples.add"
    -- >
    -- > main = do
    -- >        let x = 4
    -- >            y = 7
    -- >        z <- add server x y
    -- >        putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z)
    --
    -----------------------------------------------------------------------------

    module Network.XmlRpc.Client
        (
         remote, remoteWithHeaders,
         call, callWithHeaders,
         Remote
        ) where

    import           Network.XmlRpc.Internals

    import           Control.Monad.Fail         (MonadFail)
    import qualified Control.Monad.Fail         as Fail
    import           Data.Functor               ((<$>))
    import           Data.Int
    import           Data.Maybe
    import           Network.URI
    import           Text.Read.Compat           (readMaybe)

    import           Network.Http.Client        (Method (..), Request,
                                                 baselineContextSSL, buildRequest,
                                                 closeConnection, getStatusCode,
                                                 getStatusMessage, http,
                                                 inputStreamBody, openConnection,
                                                 openConnectionSSL, receiveResponse,
                                                 sendRequest, setAuthorizationBasic,
                                                 setContentLength, setContentType,
                                                 setHeader)
    import           OpenSSL
    import qualified System.IO.Streams          as Streams

    import qualified Data.ByteString.Char8      as BS
    import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, fromChunks,
                                                        length, unpack)
    import qualified Data.ByteString.Lazy.UTF8  as U

    -- | Gets the return value from a method response.
    --   Throws an exception if the response was a fault.
    handleResponse :: MonadFail m => MethodResponse -> m Value
    handleResponse :: forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
    handleResponse (Return Value
    v)       = Value -> m Value
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Value
    v
    handleResponse (Fault Int
    code [Char]
    str) = [Char] -> m Value
    forall a. [Char] -> m a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail ([Char]
    "Error " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    code [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ": " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    str)

    type HeadersAList = [(BS.ByteString, BS.ByteString)]

    -- | Sends a method call to a server and returns the response.
    --   Throws an exception if the response was an error.
    doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse
    doCall :: [Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
    doCall [Char]
    url HeadersAList
    headers MethodCall
    mc =
        do
        let req :: ByteString
    req = MethodCall -> ByteString
    renderCall MethodCall
    mc
        ByteString
    resp <- IO ByteString -> Err IO ByteString
    forall a. IO a -> Err IO a
    ioErrorToErr (IO ByteString -> Err IO ByteString)
    -> IO ByteString -> Err IO ByteString
    forall a b. (a -> b) -> a -> b
    $ [Char] -> HeadersAList -> ByteString -> IO ByteString
    post [Char]
    url HeadersAList
    headers ByteString
    req
        [Char] -> Err IO MethodResponse
    forall e (m :: * -> *).
    (Show e, MonadError e m, MonadFail m) =>
    [Char] -> Err m MethodResponse
    parseResponse (ByteString -> [Char]
    BSL.unpack ByteString
    resp)

    -- | Low-level method calling function. Use this function if
    --   you need to do custom conversions between XML-RPC types and
    --   Haskell types.
    --   Throws an exception if the response was a fault.
    call :: String -- ^ URL for the XML-RPC server.
         -> String -- ^ Method name.
         -> [Value] -- ^ The arguments.
         -> Err IO Value -- ^ The result
    call :: [Char] -> [Char] -> [Value] -> Err IO Value
    call [Char]
    url [Char]
    method [Value]
    args = [Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
    doCall [Char]
    url [] ([Char] -> [Value] -> MethodCall
    MethodCall [Char]
    method [Value]
    args) Err IO MethodResponse
    -> (MethodResponse -> Err IO Value) -> Err IO Value
    forall a b.
    ExceptT [Char] IO a
    -> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MethodResponse -> Err IO Value
    forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
    handleResponse

    -- | Low-level method calling function. Use this function if
    --   you need to do custom conversions between XML-RPC types and
    --   Haskell types. Takes a list of extra headers to add to the
    --   HTTP request.
    --   Throws an exception if the response was a fault.
    callWithHeaders :: String -- ^ URL for the XML-RPC server.
                    -> String -- ^ Method name.
                    -> HeadersAList -- ^ Extra headers to add to HTTP request.
                    -> [Value] -- ^ The arguments.
                    -> Err IO Value -- ^ The result
    callWithHeaders :: [Char] -> [Char] -> HeadersAList -> [Value] -> Err IO Value
    callWithHeaders [Char]
    url [Char]
    method HeadersAList
    headers [Value]
    args =
        [Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
    doCall [Char]
    url HeadersAList
    headers ([Char] -> [Value] -> MethodCall
    MethodCall [Char]
    method [Value]
    args) Err IO MethodResponse
    -> (MethodResponse -> Err IO Value) -> Err IO Value
    forall a b.
    ExceptT [Char] IO a
    -> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MethodResponse -> Err IO Value
    forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
    handleResponse

    -- | Call a remote method.
    remote :: Remote a =>
              String -- ^ Server URL. May contain username and password on
                     --   the format username:password\@ before the hostname.
           -> String -- ^ Remote method name.
           -> a      -- ^ Any function
                     -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
                     -- t1 -> ... -> tn -> IO r@
    remote :: forall a. Remote a => [Char] -> [Char] -> a
    remote [Char]
    u [Char]
    m = ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
    forall a.
    Remote a =>
    ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
    remote_ (\[Char]
    e -> [Char]
    "Error calling " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    m [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ": " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    e) ([Char] -> [Char] -> [Value] -> Err IO Value
    call [Char]
    u [Char]
    m)

    -- | Call a remote method. Takes a list of extra headers to add to the HTTP
    --   request.
    remoteWithHeaders :: Remote a =>
                         String   -- ^ Server URL. May contain username and password on
                                  --   the format username:password\@ before the hostname.
                      -> String   -- ^ Remote method name.
                      -> HeadersAList -- ^ Extra headers to add to HTTP request.
                      -> a        -- ^ Any function
                                  -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
                                  -- t1 -> ... -> tn -> IO r@
    remoteWithHeaders :: forall a. Remote a => [Char] -> [Char] -> HeadersAList -> a
    remoteWithHeaders [Char]
    u [Char]
    m HeadersAList
    headers =
        ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
    forall a.
    Remote a =>
    ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
    remote_ (\[Char]
    e -> [Char]
    "Error calling " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    m [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ": " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    e)
                ([Char] -> [Char] -> HeadersAList -> [Value] -> Err IO Value
    callWithHeaders [Char]
    u [Char]
    m HeadersAList
    headers)

    class Remote a where
        remote_ :: (String -> String)        -- ^ Will be applied to all error
                                             --   messages.
                -> ([Value] -> Err IO Value)
                -> a

    instance XmlRpcType a => Remote (IO a) where
        remote_ :: ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> IO a
    remote_ [Char] -> [Char]
    h [Value] -> Err IO Value
    f = ([Char] -> IO a) -> Err IO a -> IO a
    forall (m :: * -> *) a.
    MonadFail m =>
    ([Char] -> m a) -> Err m a -> m a
    handleError ([Char] -> IO a
    forall a. [Char] -> IO a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail ([Char] -> IO a) -> ([Char] -> [Char]) -> [Char] -> IO a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> [Char]
    h) (Err IO a -> IO a) -> Err IO a -> IO a
    forall a b. (a -> b) -> a -> b
    $ [Value] -> Err IO Value
    f [] Err IO Value -> (Value -> Err IO a) -> Err IO a
    forall a b.
    ExceptT [Char] IO a
    -> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Value -> Err IO a
    forall a (m :: * -> *).
    (XmlRpcType a, MonadFail m) =>
    Value -> Err m a
    forall (m :: * -> *). MonadFail m => Value -> Err m a
    fromValue

    instance (XmlRpcType a, Remote b) => Remote (a -> b) where
        remote_ :: ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a -> b
    remote_ [Char] -> [Char]
    h [Value] -> Err IO Value
    f a
    x = ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> b
    forall a.
    Remote a =>
    ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
    remote_ [Char] -> [Char]
    h (\[Value]
    xs -> [Value] -> Err IO Value
    f (a -> Value
    forall a. XmlRpcType a => a -> Value
    toValue a
    xValue -> [Value] -> [Value]
    forall a. a -> [a] -> [a]
    :[Value]
    xs))

    --
    -- HTTP functions
    --

    userAgent :: BS.ByteString
    userAgent :: ByteString
    userAgent = ByteString
    "Haskell XmlRpcClient/0.1"

    -- | Post some content to a uri, return the content of the response
    --   or an error.
    -- FIXME: should we really use fail?

    post :: String -> HeadersAList -> BSL.ByteString -> IO U.ByteString
    post :: [Char] -> HeadersAList -> ByteString -> IO ByteString
    post [Char]
    url HeadersAList
    headers ByteString
    content = do
        URI
    uri <- [Char] -> Maybe URI -> IO URI
    forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
    maybeFail ([Char]
    "Bad URI: '" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    url [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "'") ([Char] -> Maybe URI
    parseURI [Char]
    url)
        let a :: Maybe URIAuth
    a = URI -> Maybe URIAuth
    uriAuthority URI
    uri
        URIAuth
    auth <- [Char] -> Maybe URIAuth -> IO URIAuth
    forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
    maybeFail ([Char]
    "Bad URI authority: '" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Maybe [Char] -> [Char]
    forall a. Show a => a -> [Char]
    show ((URIAuth -> [Char]) -> Maybe URIAuth -> Maybe [Char]
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap URIAuth -> [Char]
    showAuth Maybe URIAuth
    a) [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "'") Maybe URIAuth
    a
        URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
    post_ URI
    uri URIAuth
    auth HeadersAList
    headers ByteString
    content
      where showAuth :: URIAuth -> [Char]
    showAuth (URIAuth [Char]
    u [Char]
    r [Char]
    p) = [Char]
    "URIAuth "[Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++[Char]
    u[Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++[Char]
    " "[Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++[Char]
    r[Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++[Char]
    " "[Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++[Char]
    p

    -- | Post some content to a uri, return the content of the response
    --   or an error.
    -- FIXME: should we really use fail?
    post_ :: URI -> URIAuth -> HeadersAList -> BSL.ByteString -> IO U.ByteString
    post_ :: URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
    post_ URI
    uri URIAuth
    auth HeadersAList
    headers ByteString
    content = IO ByteString -> IO ByteString
    forall a. IO a -> IO a
    withOpenSSL (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ do
        let hostname :: ByteString
    hostname = [Char] -> ByteString
    BS.pack (URIAuth -> [Char]
    uriRegName URIAuth
    auth)
            port :: a -> a
    port a
    base = a -> Maybe a -> a
    forall a. a -> Maybe a -> a
    fromMaybe a
    base ([Char] -> Maybe a
    forall a. Read a => [Char] -> Maybe a
    readMaybe ([Char] -> Maybe a) -> [Char] -> Maybe a
    forall a b. (a -> b) -> a -> b
    $ Int -> [Char] -> [Char]
    forall a. Int -> [a] -> [a]
    drop Int
    1 ([Char] -> [Char]) -> [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ URIAuth -> [Char]
    uriPort URIAuth
    auth)

        Connection
    c <- case [Char] -> [Char]
    forall a. HasCallStack => [a] -> [a]
    init ([Char] -> [Char]) -> [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ URI -> [Char]
    uriScheme URI
    uri of
            [Char]
    "http"  ->
                ByteString -> Port -> IO Connection
    openConnection ByteString
    hostname (Port -> Port
    forall {a}. Read a => a -> a
    port Port
    80)
            [Char]
    "https" -> do
                SSLContext
    ctx <- IO SSLContext
    baselineContextSSL
                SSLContext -> ByteString -> Port -> IO Connection
    openConnectionSSL SSLContext
    ctx ByteString
    hostname (Port -> Port
    forall {a}. Read a => a -> a
    port Port
    443)
            [Char]
    x -> [Char] -> IO Connection
    forall a. [Char] -> IO a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail ([Char]
    "Unknown scheme: '" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    x [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "'!")

        Request
    req  <- URI -> URIAuth -> HeadersAList -> Int64 -> IO Request
    request URI
    uri URIAuth
    auth HeadersAList
    headers (ByteString -> Int64
    BSL.length ByteString
    content)
        OutputStream Builder -> IO ()
    body <- InputStream ByteString -> OutputStream Builder -> IO ()
    inputStreamBody (InputStream ByteString -> OutputStream Builder -> IO ())
    -> IO (InputStream ByteString)
    -> IO (OutputStream Builder -> IO ())
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ByteString -> IO (InputStream ByteString)
    Streams.fromLazyByteString ByteString
    content

        ()
    _ <- Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
    forall α.
    Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
    sendRequest Connection
    c Request
    req OutputStream Builder -> IO ()
    body

        ByteString
    s <- Connection
    -> (Response -> InputStream ByteString -> IO ByteString)
    -> IO ByteString
    forall β.
    Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
    receiveResponse Connection
    c ((Response -> InputStream ByteString -> IO ByteString)
     -> IO ByteString)
    -> (Response -> InputStream ByteString -> IO ByteString)
    -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Response
    resp InputStream ByteString
    i -> do
            case Response -> Int
    getStatusCode Response
    resp of
              Int
    200 -> InputStream ByteString -> IO ByteString
    readLazyByteString InputStream ByteString
    i
              Int
    _   -> [Char] -> IO ByteString
    forall a. [Char] -> IO a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail (Int -> [Char]
    forall a. Show a => a -> [Char]
    show (Response -> Int
    getStatusCode Response
    resp) [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> [Char]
    BS.unpack (Response -> ByteString
    getStatusMessage Response
    resp))

        Connection -> IO ()
    closeConnection Connection
    c

        ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    s

    readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString
    readLazyByteString :: InputStream ByteString -> IO ByteString
    readLazyByteString InputStream ByteString
    i = [ByteString] -> ByteString
    BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO [ByteString]
    go
      where
        go :: IO [BS.ByteString]
        go :: IO [ByteString]
    go = do
          Maybe ByteString
    res <- InputStream ByteString -> IO (Maybe ByteString)
    forall a. InputStream a -> IO (Maybe a)
    Streams.read InputStream ByteString
    i
          case Maybe ByteString
    res of
            Maybe ByteString
    Nothing -> [ByteString] -> IO [ByteString]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            Just ByteString
    bs -> (ByteString
    bsByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    :) ([ByteString] -> [ByteString])
    -> IO [ByteString] -> IO [ByteString]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO [ByteString]
    go

    -- | Create an XML-RPC compliant HTTP request.
    request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request
    request :: URI -> URIAuth -> HeadersAList -> Int64 -> IO Request
    request URI
    uri URIAuth
    auth HeadersAList
    usrHeaders Int64
    len = RequestBuilder () -> IO Request
    forall (ν :: * -> *) α. Monad ν => RequestBuilder α -> ν Request
    buildRequest (RequestBuilder () -> IO Request)
    -> RequestBuilder () -> IO Request
    forall a b. (a -> b) -> a -> b
    $ do
        Method -> ByteString -> RequestBuilder ()
    http Method
    POST ([Char] -> ByteString
    BS.pack ([Char] -> ByteString) -> [Char] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ URI -> [Char]
    uriPath URI
    uri)
        ByteString -> RequestBuilder ()
    setContentType ByteString
    "text/xml"
        Int64 -> RequestBuilder ()
    setContentLength Int64
    len

        case URIAuth -> (Maybe [Char], Maybe [Char])
    parseUserInfo URIAuth
    auth of
          (Just [Char]
    user, Just [Char]
    pass) -> ByteString -> ByteString -> RequestBuilder ()
    setAuthorizationBasic ([Char] -> ByteString
    BS.pack [Char]
    user) ([Char] -> ByteString
    BS.pack [Char]
    pass)
          (Maybe [Char], Maybe [Char])
    _                      -> () -> RequestBuilder ()
    forall a. a -> RequestBuilder a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        ((ByteString, ByteString) -> RequestBuilder ())
    -> HeadersAList -> RequestBuilder ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ ((ByteString -> ByteString -> RequestBuilder ())
    -> (ByteString, ByteString) -> RequestBuilder ()
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry ByteString -> ByteString -> RequestBuilder ()
    setHeader) HeadersAList
    usrHeaders

        ByteString -> ByteString -> RequestBuilder ()
    setHeader ByteString
    "User-Agent" ByteString
    userAgent

        where
          parseUserInfo :: URIAuth -> (Maybe [Char], Maybe [Char])
    parseUserInfo URIAuth
    info = let ([Char]
    u,[Char]
    pw) = (Char -> Bool) -> [Char] -> ([Char], [Char])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    ':') ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
    forall a b. (a -> b) -> a -> b
    $ URIAuth -> [Char]
    uriUserInfo URIAuth
    info
                               in ( if [Char] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    u then Maybe [Char]
    forall a. Maybe a
    Nothing else [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    u
                                  , if [Char] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    pw then Maybe [Char]
    forall a. Maybe a
    Nothing else [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
    forall a b. (a -> b) -> a -> b
    $ [Char] -> [Char]
    dropAtEnd ([Char] -> [Char]) -> [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ [Char] -> [Char]
    forall a. HasCallStack => [a] -> [a]
    tail [Char]
    pw )

    --
    -- Utility functions
    --

    maybeFail :: MonadFail m => String -> Maybe a -> m a
    maybeFail :: forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
    maybeFail [Char]
    msg = m a -> (a -> m a) -> Maybe a -> m a
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ([Char] -> m a
    forall a. [Char] -> m a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    Fail.fail [Char]
    msg) a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    dropAtEnd :: String -> String
    dropAtEnd :: [Char] -> [Char]
    dropAtEnd [Char]
    l = Int -> [Char] -> [Char]
    forall a. Int -> [a] -> [a]
    take ([Char] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Char]
    l Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [Char]
    l