module Network.XmlRpc.Client
(
remote,
call,
Remote
) where
import Network.XmlRpc.Base64 as Base64
import Network.XmlRpc.Internals
import Control.Exception (handleJust, userErrors)
import Data.Char
import Data.Maybe
import Data.Word (Word8)
import Network.URI
import Network.Socket (withSocketsDo)
import Network.HTTP
handleResponse :: Monad m => MethodResponse -> m Value
handleResponse (Return v) = return v
handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ str)
doCall :: String -> MethodCall -> Err IO MethodResponse
doCall url mc =
do
let req = renderCall mc
resp <- ioErrorToErr $ post url req
parseResponse resp
call :: String
-> String
-> [Value]
-> Err IO Value
call url method args = doCall url (MethodCall method args) >>= handleResponse
remote :: Remote a =>
String
-> String
-> a
remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m)
class Remote a where
remote_ :: (String -> String)
-> ([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))
userAgent :: String
userAgent = "Haskell XmlRpcClient/0.1"
handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a
handleE h (Left e) = h e
handleE _ (Right v) = return v
post :: String -> String -> IO String
post url content = do
uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url)
let a = authority uri
auth <- maybeFail ("Bad URI authority: '" ++ a ++ "'") (parseURIAuthority a)
post_ uri auth content
post_ :: URI -> URIAuthority -> String -> IO String
post_ uri auth content =
do
eresp <- simpleHTTP (request uri auth content)
resp <- handleE (fail . show) eresp
case rspCode resp of
(2,0,0) -> return (rspBody resp)
_ -> fail (httpError resp)
where
showRspCode (a,b,c) = map intToDigit [a,b,c]
httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp
request :: URI -> URIAuthority -> String -> Request
request uri auth content = Request{ rqURI = uri,
rqMethod = POST,
rqHeaders = headers,
rqBody = content }
where
headers = [Header HdrUserAgent userAgent,
Header HdrContentType "text/xml",
Header HdrContentLength (show (length content))
] ++ maybeToList (authHdr (user auth) (password auth))
authHdr :: Maybe String
-> Maybe String
-> Maybe Header
authHdr Nothing Nothing = Nothing
authHdr u p = Just (Header HdrAuthorization ("Basic " ++ base64encode user_pass))
where user_pass = fromMaybe "" u ++ ":" ++ fromMaybe "" p
base64encode = encode . stringToOctets
stringToOctets :: String -> [Word8]
stringToOctets = map (fromIntegral . fromEnum)
maybeFail :: Monad m => String -> Maybe a -> m a
maybeFail msg = maybe (fail msg) return