    {-# 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           Data.Functor               ((<$>))
    import           Data.Maybe
    import           Data.Int
    import           Network.URI
    import           Text.Read.Compat           (readMaybe)

    import           Network.Http.Client        (Method (..), Request,
                                                 baselineContextSSL, buildRequest,
                                                 closeConnection, getStatusCode,
                                                 getStatusMessage, http, openConnection,
                                                 inputStreamBody, openConnectionSSL,
                                                 receiveResponse, sendRequest,
                                                 setAuthorizationBasic,
                                                 setContentType, setContentLength, 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,
                                                        unpack, length)
    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 :: Monad m => MethodResponse -> m Value
    handleResponse (Return v) = return v
    handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ 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 url headers mc =
        do
        let req = renderCall mc
        resp <- ioErrorToErr $ post url headers req
        parseResponse (BSL.unpack 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 url method args = doCall url [] (MethodCall method args) >>= 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 url method headers args =
        doCall url headers (MethodCall method args) >>= 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 u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u 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 u m headers =
        remote_ (\e -> "Error calling " ++ m ++ ": " ++ e)
                (callWithHeaders u m 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_ h f = handleError (fail . h) $ f [] >>= fromValue

    instance (XmlRpcType a, Remote b) => Remote (a -> b) where
        remote_ h f x = remote_ h (\xs -> f (toValue x:xs))

    --
    -- HTTP functions
    --

    userAgent :: BS.ByteString
    userAgent = "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 url headers content = do
        uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url)
        let a = uriAuthority uri
        auth <- maybeFail ("Bad URI authority: '" ++ show (fmap showAuth a) ++ "'") a
        post_ uri auth headers content
      where showAuth (URIAuth u r p) = "URIAuth "++u++" "++r++" "++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 auth headers content = withOpenSSL $ do
        let hostname = BS.pack (uriRegName auth)
            port base = fromMaybe base (readMaybe $ drop 1 $ uriPort auth)

        c <- case init $ uriScheme uri of
            "http"  ->
                openConnection hostname (port 80)
            "https" -> do
                ctx <- baselineContextSSL
                openConnectionSSL ctx hostname (port 443)
            x -> fail ("Unknown scheme: '" ++ x ++ "'!")

        req  <- request uri auth headers (BSL.length content)
        body <- inputStreamBody <$> Streams.fromLazyByteString content

        _ <- sendRequest c req body

        s <- receiveResponse c $ \resp i -> do
            case getStatusCode resp of
              200 -> readLazyByteString i
              _   -> fail (show (getStatusCode resp) ++ " " ++ BS.unpack (getStatusMessage resp))

        closeConnection c

        return s

    readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString
    readLazyByteString i = BSL.fromChunks <$> go
      where
        go :: IO [BS.ByteString]
        go = do
          res <- Streams.read i
          case res of
            Nothing -> return []
            Just bs -> (bs:) <$> go

    -- | Create an XML-RPC compliant HTTP request.
    request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request
    request uri auth usrHeaders len = buildRequest $ do
        http POST (BS.pack $ uriPath uri)
        setContentType "text/xml"
        setContentLength len

        case parseUserInfo auth of
          (Just user, Just pass) -> setAuthorizationBasic (BS.pack user) (BS.pack pass)
          _                      -> return ()

        mapM_ (uncurry setHeader) usrHeaders

        setHeader "User-Agent" userAgent

        where
          parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info
                               in ( if null u then Nothing else Just u
                                  , if null pw then Nothing else Just $ dropAtEnd $ tail pw )

    --
    -- Utility functions
    --

    maybeFail :: Monad m => String -> Maybe a -> m a
    maybeFail msg = maybe (fail msg) return

    dropAtEnd :: String -> String
    dropAtEnd l = take (length l - 1) l