{-# LANGUAGE OverloadedStrings #-}
module Network.XmlRpc.Client
(
remote, remoteWithHeaders,
call, callWithHeaders,
Remote
) where
import Network.XmlRpc.Internals
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail as Fail
import Data.Functor ((<$>))
import Data.Int
import Data.Maybe
import Network.URI
import Text.Read.Compat (readMaybe)
import Network.Http.Client (Method (..), Request,
baselineContextSSL, buildRequest,
closeConnection, getStatusCode,
getStatusMessage, http,
inputStreamBody, openConnection,
openConnectionSSL, receiveResponse,
sendRequest, setAuthorizationBasic,
setContentLength, setContentType,
setHeader)
import OpenSSL
import qualified System.IO.Streams as Streams
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, fromChunks,
length, unpack)
import qualified Data.ByteString.Lazy.UTF8 as U
handleResponse :: MonadFail m => MethodResponse -> m Value
handleResponse :: forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
handleResponse (Return Value
v) = forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
handleResponse (Fault Int
code [Char]
str) = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Error " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
code forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
str)
type = [(BS.ByteString, BS.ByteString)]
doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall :: [Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall [Char]
url HeadersAList
headers MethodCall
mc =
do
let req :: ByteString
req = MethodCall -> ByteString
renderCall MethodCall
mc
ByteString
resp <- forall a. IO a -> Err IO a
ioErrorToErr forall a b. (a -> b) -> a -> b
$ [Char] -> HeadersAList -> ByteString -> IO ByteString
post [Char]
url HeadersAList
headers ByteString
req
forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
[Char] -> Err m MethodResponse
parseResponse (ByteString -> [Char]
BSL.unpack ByteString
resp)
call :: String
-> String
-> [Value]
-> Err IO Value
call :: [Char] -> [Char] -> [Value] -> Err IO Value
call [Char]
url [Char]
method [Value]
args = [Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall [Char]
url [] ([Char] -> [Value] -> MethodCall
MethodCall [Char]
method [Value]
args) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
handleResponse
callWithHeaders :: String
-> String
-> HeadersAList
-> [Value]
-> Err IO Value
[Char]
url [Char]
method HeadersAList
headers [Value]
args =
[Char] -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall [Char]
url HeadersAList
headers ([Char] -> [Value] -> MethodCall
MethodCall [Char]
method [Value]
args) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
handleResponse
remote :: Remote a =>
String
-> String
-> a
remote :: forall a. Remote a => [Char] -> [Char] -> a
remote [Char]
u [Char]
m = forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ (\[Char]
e -> [Char]
"Error calling " forall a. [a] -> [a] -> [a]
++ [Char]
m forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
e) ([Char] -> [Char] -> [Value] -> Err IO Value
call [Char]
u [Char]
m)
remoteWithHeaders :: Remote a =>
String
-> String
-> HeadersAList
-> a
[Char]
u [Char]
m HeadersAList
headers =
forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ (\[Char]
e -> [Char]
"Error calling " forall a. [a] -> [a] -> [a]
++ [Char]
m forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
e)
([Char] -> [Char] -> HeadersAList -> [Value] -> Err IO Value
callWithHeaders [Char]
u [Char]
m HeadersAList
headers)
class Remote a where
remote_ :: (String -> String)
-> ([Value] -> Err IO Value)
-> a
instance XmlRpcType a => Remote (IO a) where
remote_ :: ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> IO a
remote_ [Char] -> [Char]
h [Value] -> Err IO Value
f = forall (m :: * -> *) a.
MonadFail m =>
([Char] -> m a) -> Err m a -> m a
handleError (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
h) forall a b. (a -> b) -> a -> b
$ [Value] -> Err IO Value
f [] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue
instance (XmlRpcType a, Remote b) => Remote (a -> b) where
remote_ :: ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a -> b
remote_ [Char] -> [Char]
h [Value] -> Err IO Value
f a
x = forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ [Char] -> [Char]
h (\[Value]
xs -> [Value] -> Err IO Value
f (forall a. XmlRpcType a => a -> Value
toValue a
xforall a. a -> [a] -> [a]
:[Value]
xs))
userAgent :: BS.ByteString
userAgent :: ByteString
userAgent = ByteString
"Haskell XmlRpcClient/0.1"
post :: String -> HeadersAList -> BSL.ByteString -> IO U.ByteString
post :: [Char] -> HeadersAList -> ByteString -> IO ByteString
post [Char]
url HeadersAList
headers ByteString
content = do
URI
uri <- forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail ([Char]
"Bad URI: '" forall a. [a] -> [a] -> [a]
++ [Char]
url forall a. [a] -> [a] -> [a]
++ [Char]
"'") ([Char] -> Maybe URI
parseURI [Char]
url)
let a :: Maybe URIAuth
a = URI -> Maybe URIAuth
uriAuthority URI
uri
URIAuth
auth <- forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail ([Char]
"Bad URI authority: '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URIAuth -> [Char]
showAuth Maybe URIAuth
a) forall a. [a] -> [a] -> [a]
++ [Char]
"'") Maybe URIAuth
a
URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
post_ URI
uri URIAuth
auth HeadersAList
headers ByteString
content
where showAuth :: URIAuth -> [Char]
showAuth (URIAuth [Char]
u [Char]
r [Char]
p) = [Char]
"URIAuth "forall a. [a] -> [a] -> [a]
++[Char]
uforall a. [a] -> [a] -> [a]
++[Char]
" "forall a. [a] -> [a] -> [a]
++[Char]
rforall a. [a] -> [a] -> [a]
++[Char]
" "forall a. [a] -> [a] -> [a]
++[Char]
p
post_ :: URI -> URIAuth -> HeadersAList -> BSL.ByteString -> IO U.ByteString
post_ :: URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
post_ URI
uri URIAuth
auth HeadersAList
headers ByteString
content = forall a. IO a -> IO a
withOpenSSL forall a b. (a -> b) -> a -> b
$ do
let hostname :: ByteString
hostname = [Char] -> ByteString
BS.pack (URIAuth -> [Char]
uriRegName URIAuth
auth)
port :: a -> a
port a
base = forall a. a -> Maybe a -> a
fromMaybe a
base (forall a. Read a => [Char] -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriPort URIAuth
auth)
Connection
c <- case forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriScheme URI
uri of
[Char]
"http" ->
ByteString -> Port -> IO Connection
openConnection ByteString
hostname (forall {a}. Read a => a -> a
port Port
80)
[Char]
"https" -> do
SSLContext
ctx <- IO SSLContext
baselineContextSSL
SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
hostname (forall {a}. Read a => a -> a
port Port
443)
[Char]
x -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unknown scheme: '" forall a. [a] -> [a] -> [a]
++ [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
"'!")
Request
req <- URI -> URIAuth -> HeadersAList -> Int64 -> IO Request
request URI
uri URIAuth
auth HeadersAList
headers (ByteString -> Int64
BSL.length ByteString
content)
OutputStream Builder -> IO ()
body <- InputStream ByteString -> OutputStream Builder -> IO ()
inputStreamBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (InputStream ByteString)
Streams.fromLazyByteString ByteString
content
()
_ <- forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
req OutputStream Builder -> IO ()
body
ByteString
s <- forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c forall a b. (a -> b) -> a -> b
$ \Response
resp InputStream ByteString
i -> do
case Response -> Int
getStatusCode Response
resp of
Int
200 -> InputStream ByteString -> IO ByteString
readLazyByteString InputStream ByteString
i
Int
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall a. Show a => a -> [Char]
show (Response -> Int
getStatusCode Response
resp) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack (Response -> ByteString
getStatusMessage Response
resp))
Connection -> IO ()
closeConnection Connection
c
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s
readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString
readLazyByteString :: InputStream ByteString -> IO ByteString
readLazyByteString InputStream ByteString
i = [ByteString] -> ByteString
BSL.fromChunks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ByteString]
go
where
go :: IO [BS.ByteString]
go :: IO [ByteString]
go = do
Maybe ByteString
res <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
i
case Maybe ByteString
res of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just ByteString
bs -> (ByteString
bsforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ByteString]
go
request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request
request :: URI -> URIAuth -> HeadersAList -> Int64 -> IO Request
request URI
uri URIAuth
auth HeadersAList
usrHeaders Int64
len = forall (ν :: * -> *) α. Monad ν => RequestBuilder α -> ν Request
buildRequest forall a b. (a -> b) -> a -> b
$ do
Method -> ByteString -> RequestBuilder ()
http Method
POST ([Char] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriPath URI
uri)
ByteString -> RequestBuilder ()
setContentType ByteString
"text/xml"
Int64 -> RequestBuilder ()
setContentLength Int64
len
case URIAuth -> (Maybe [Char], Maybe [Char])
parseUserInfo URIAuth
auth of
(Just [Char]
user, Just [Char]
pass) -> ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic ([Char] -> ByteString
BS.pack [Char]
user) ([Char] -> ByteString
BS.pack [Char]
pass)
(Maybe [Char], Maybe [Char])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> RequestBuilder ()
setHeader) HeadersAList
usrHeaders
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"User-Agent" ByteString
userAgent
where
parseUserInfo :: URIAuth -> (Maybe [Char], Maybe [Char])
parseUserInfo URIAuth
info = let ([Char]
u,[Char]
pw) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
':') forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriUserInfo URIAuth
info
in ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
u then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [Char]
u
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pw then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
dropAtEnd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Char]
pw )
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail :: forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail [Char]
msg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail [Char]
msg) forall (m :: * -> *) a. Monad m => a -> m a
return
dropAtEnd :: String -> String
dropAtEnd :: [Char] -> [Char]
dropAtEnd [Char]
l = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
l forall a. Num a => a -> a -> a
- Int
1) [Char]
l