----------------------------------------------------------------------------- -- | -- 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 . -- -- 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 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 -> [Header] -> MethodCall -> Err IO MethodResponse doCall url headers mc = do let req = renderCall mc --FIXME: remove --putStrLn req resp <- ioErrorToErr $ post url headers 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 -- | 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. -> [Header] -- ^ 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. -> [Header] -- ^ 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 :: 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 -> [Header] -> BSL.ByteString -> IO String 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 -> [Header] -> BSL.ByteString -> IO String post_ uri auth headers content = do eresp <- simpleHTTP (request uri auth headers (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 -> [Header] -> BS.ByteString -> Request BS.ByteString request uri auth headers 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) ++ headers 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