{-# 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 :: MethodResponse -> m Value
handleResponse (Return Value
v) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
handleResponse (Fault Int
code String
str) = String -> m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
type = [(BS.ByteString, BS.ByteString)]
doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall String
url HeadersAList
headers MethodCall
mc =
do
let req :: ByteString
req = MethodCall -> ByteString
renderCall MethodCall
mc
ByteString
resp <- IO ByteString -> Err IO ByteString
forall a. IO a -> Err IO a
ioErrorToErr (IO ByteString -> Err IO ByteString)
-> IO ByteString -> Err IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> HeadersAList -> ByteString -> IO ByteString
post String
url HeadersAList
headers ByteString
req
String -> Err IO MethodResponse
forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodResponse
parseResponse (ByteString -> String
BSL.unpack ByteString
resp)
call :: String
-> String
-> [Value]
-> Err IO Value
call :: String -> String -> [Value] -> Err IO Value
call String
url String
method [Value]
args = String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall String
url [] (String -> [Value] -> MethodCall
MethodCall String
method [Value]
args) Err IO MethodResponse
-> (MethodResponse -> Err IO Value) -> Err IO Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodResponse -> Err IO Value
forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
handleResponse
callWithHeaders :: String
-> String
-> HeadersAList
-> [Value]
-> Err IO Value
String
url String
method HeadersAList
headers [Value]
args =
String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall String
url HeadersAList
headers (String -> [Value] -> MethodCall
MethodCall String
method [Value]
args) Err IO MethodResponse
-> (MethodResponse -> Err IO Value) -> Err IO Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodResponse -> Err IO Value
forall (m :: * -> *). MonadFail m => MethodResponse -> m Value
handleResponse
remote :: Remote a =>
String
-> String
-> a
remote :: String -> String -> a
remote String
u String
m = (String -> String) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ (\String
e -> String
"Error calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e) (String -> String -> [Value] -> Err IO Value
call String
u String
m)
remoteWithHeaders :: Remote a =>
String
-> String
-> HeadersAList
-> a
String
u String
m HeadersAList
headers =
(String -> String) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ (\String
e -> String
"Error calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
(String -> String -> HeadersAList -> [Value] -> Err IO Value
callWithHeaders String
u String
m HeadersAList
headers)
class Remote a where
remote_ :: (String -> String)
-> ([Value] -> Err IO Value)
-> a
instance XmlRpcType a => Remote (IO a) where
remote_ :: (String -> String) -> ([Value] -> Err IO Value) -> IO a
remote_ String -> String
h [Value] -> Err IO Value
f = (String -> IO a) -> Err IO a -> IO a
forall (m :: * -> *) a.
MonadFail m =>
(String -> m a) -> Err m a -> m a
handleError (String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> (String -> String) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
h) (Err IO a -> IO a) -> Err IO a -> IO a
forall a b. (a -> b) -> a -> b
$ [Value] -> Err IO Value
f [] Err IO Value -> (Value -> Err IO a) -> Err IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Err IO a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue
instance (XmlRpcType a, Remote b) => Remote (a -> b) where
remote_ :: (String -> String) -> ([Value] -> Err IO Value) -> a -> b
remote_ String -> String
h [Value] -> Err IO Value
f a
x = (String -> String) -> ([Value] -> Err IO Value) -> b
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ String -> String
h (\[Value]
xs -> [Value] -> Err IO Value
f (a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
xValue -> [Value] -> [Value]
forall 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 :: String -> HeadersAList -> ByteString -> IO ByteString
post String
url HeadersAList
headers ByteString
content = do
URI
uri <- String -> Maybe URI -> IO URI
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeFail (String
"Bad URI: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") (String -> Maybe URI
parseURI String
url)
let a :: Maybe URIAuth
a = URI -> Maybe URIAuth
uriAuthority URI
uri
URIAuth
auth <- String -> Maybe URIAuth -> IO URIAuth
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeFail (String
"Bad URI authority: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show ((URIAuth -> String) -> Maybe URIAuth -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URIAuth -> String
showAuth Maybe URIAuth
a) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") Maybe URIAuth
a
URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
post_ URI
uri URIAuth
auth HeadersAList
headers ByteString
content
where showAuth :: URIAuth -> String
showAuth (URIAuth String
u String
r String
p) = String
"URIAuth "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
uString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
rString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
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 = IO ByteString -> IO ByteString
forall a. IO a -> IO a
withOpenSSL (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
let hostname :: ByteString
hostname = String -> ByteString
BS.pack (URIAuth -> String
uriRegName URIAuth
auth)
port :: a -> a
port a
base = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
base (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
uriPort URIAuth
auth)
Connection
c <- case String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
uri of
String
"http" ->
ByteString -> Port -> IO Connection
openConnection ByteString
hostname (Port -> Port
forall a. Read a => a -> a
port Port
80)
String
"https" -> do
SSLContext
ctx <- IO SSLContext
baselineContextSSL
SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
hostname (Port -> Port
forall a. Read a => a -> a
port Port
443)
String
x -> String -> IO Connection
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown scheme: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'!")
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 (InputStream ByteString -> OutputStream Builder -> IO ())
-> IO (InputStream ByteString)
-> IO (OutputStream Builder -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (InputStream ByteString)
Streams.fromLazyByteString ByteString
content
()
_ <- Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
req OutputStream Builder -> IO ()
body
ByteString
s <- Connection
-> (Response -> InputStream ByteString -> IO ByteString)
-> IO ByteString
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c ((Response -> InputStream ByteString -> IO ByteString)
-> IO ByteString)
-> (Response -> InputStream ByteString -> IO ByteString)
-> IO ByteString
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
_ -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Int -> String
forall a. Show a => a -> String
show (Response -> Int
getStatusCode Response
resp) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS.unpack (Response -> ByteString
getStatusMessage Response
resp))
Connection -> IO ()
closeConnection Connection
c
ByteString -> IO ByteString
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 ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
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 <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
i
case Maybe ByteString
res of
Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just ByteString
bs -> (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
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 = RequestBuilder () -> IO Request
forall (ν :: * -> *) α. Monad ν => RequestBuilder α -> ν Request
buildRequest (RequestBuilder () -> IO Request)
-> RequestBuilder () -> IO Request
forall a b. (a -> b) -> a -> b
$ do
Method -> ByteString -> RequestBuilder ()
http Method
POST (String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
uri)
ByteString -> RequestBuilder ()
setContentType ByteString
"text/xml"
Int64 -> RequestBuilder ()
setContentLength Int64
len
case URIAuth -> (Maybe String, Maybe String)
parseUserInfo URIAuth
auth of
(Just String
user, Just String
pass) -> ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic (String -> ByteString
BS.pack String
user) (String -> ByteString
BS.pack String
pass)
(Maybe String, Maybe String)
_ -> () -> RequestBuilder ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
((ByteString, ByteString) -> RequestBuilder ())
-> HeadersAList -> RequestBuilder ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ByteString -> ByteString -> RequestBuilder ())
-> (ByteString, ByteString) -> RequestBuilder ()
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 String, Maybe String)
parseUserInfo URIAuth
info = let (String
u,String
pw) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
uriUserInfo URIAuth
info
in ( if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
u
, if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pw then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
dropAtEnd (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
pw )
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail :: String -> Maybe a -> m a
maybeFail String
msg = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
dropAtEnd :: String -> String
dropAtEnd :: String -> String
dropAtEnd String
l = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
l