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.Socket (withSocketsDo)
import Network.URI
import Network.HTTP
import Network.Stream
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, toChunks)
import qualified Data.ByteString.UTF8 as U
handleResponse :: Monad m => MethodResponse -> m Value
handleResponse (Return v) = return v
handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ str)
doCall :: String -> [Header] -> MethodCall -> Err IO MethodResponse
doCall url headers mc =
do
let req = renderCall mc
resp <- ioErrorToErr $ post url headers req
parseResponse resp
call :: String
-> String
-> [Value]
-> Err IO Value
call url method args = doCall url [] (MethodCall method args) >>= handleResponse
callWithHeaders :: String
-> String
-> [Header]
-> [Value]
-> Err IO Value
callWithHeaders url method headers args =
doCall url headers (MethodCall method args) >>= handleResponse
remote :: Remote a =>
String
-> String
-> a
remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m)
remoteWithHeaders :: Remote a =>
String
-> String
-> [Header]
-> a
remoteWithHeaders u m headers =
remote_ (\e -> "Error calling " ++ m ++ ": " ++ e)
(callWithHeaders u m headers)
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 -> [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_ :: 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
request :: URI -> URIAuth -> [Header] -> BS.ByteString -> Request BS.ByteString
request uri auth usrHeaders 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 (uncurry authHdr . parseUserInfo $ auth)
++ usrHeaders
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))
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 = BS.unpack . Base64.encode . BS.pack
maybeFail :: Monad m => String -> Maybe a -> m a
maybeFail msg = maybe (fail msg) return