module Network.XmlRpc.Client
(
remote,
call,
Remote
) where
import qualified 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
import Network.Stream
import qualified Data.ByteString.UTF8 as U
import qualified Data.ByteString as BS
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 (U.fromString 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
request :: URI -> URIAuthority -> BS.ByteString -> Request BS.ByteString
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 (BS.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 = Base64.encode . stringToOctets
stringToOctets :: String -> [Word8]
stringToOctets = map (fromIntegral . fromEnum)
maybeFail :: Monad m => String -> Maybe a -> m a
maybeFail msg = maybe (fail msg) return