    -----------------------------------------------------------------------------
    -- |
    -- 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,
         call,
         Remote
        ) where

    import qualified Network.XmlRpc.Base64 as Base64
    import Network.XmlRpc.Internals

    import Control.Exception (handleJust)
    import Data.Char
    import Data.Maybe
    import Data.Word (Word8)
    import Network.URI
    import Network.Socket (withSocketsDo)

    import Network.HTTP
    import Network.Stream

    import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, toChunks)
    import qualified Data.ByteString.UTF8 as U
    import qualified Data.ByteString.Char8 as BS

    -- | 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)

    -- | Sends a method call to a server and returns the response.
    --   Throws an exception if the response was an error.
    doCall :: String -> MethodCall -> Err IO MethodResponse
    doCall url mc =
        do
        let req = renderCall mc
        --FIXME: remove
        --putStrLn req
        resp <- ioErrorToErr $ post url req
        --FIXME: remove
        --putStrLn resp
        parseResponse 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

    -- | 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)

    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 :: String
    userAgent = "Haskell XmlRpcClient/0.1"

    -- | Handle connection errors.
    handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a
    handleE h (Left e) = h e
    handleE _ (Right v) = return v

    -- | Post some content to a uri, return the content of the response
    --   or an error.
    -- FIXME: should we really use fail?
    post :: String -> BSL.ByteString -> IO String
    post url 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 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 -> BSL.ByteString -> IO String
    post_ uri auth content =
        do
        eresp <- simpleHTTP (request uri auth (BS.concat . BSL.toChunks $ content))
        resp <- handleE (fail . show) eresp
        case rspCode resp of
    		      (2,0,0) -> return (U.toString (rspBody resp))
    		      _ -> fail (httpError resp)
        where
        showRspCode (a,b,c) = map intToDigit [a,b,c]
        httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp

    -- | Create an XML-RPC compliant HTTP request.
    request :: URI -> URIAuth -> BS.ByteString -> Request BS.ByteString
    request uri auth content = Request{ rqURI = uri,
    				    rqMethod = POST,
    				    rqHeaders = headers,
    				    rqBody = content }
        where
        -- the HTTP module adds a Host header based on the URI
        headers = [Header HdrUserAgent userAgent,
    	       Header HdrContentType "text/xml",
    	       Header HdrContentLength (show (BS.length content))
    	      ] ++ maybeToList (uncurry authHdr . parseUserInfo $ auth)
        parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info
                             in ( if null u then Nothing else Just u
                                , if null pw then Nothing else Just (tail pw))

    -- | Creates an Authorization header using the Basic scheme,
    --   see RFC 2617 section 2.
    authHdr :: Maybe String -- ^ User name, if any
    	-> Maybe String -- ^ Password, if any
    	-> Maybe Header -- ^ If user name or password was given, returns
    	                --   an Authorization header, otherwise 'Nothing'
    authHdr Nothing Nothing = Nothing
    authHdr u p = Just (Header HdrAuthorization ("Basic " ++ base64encode user_pass))
    	where user_pass    = fromMaybe "" u ++ ":" ++ fromMaybe "" p
    	      base64encode = BS.unpack . Base64.encode . BS.pack

    --
    -- Utility functions
    --

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