{-# 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.List (uncons)
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) = Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
handleResponse (Fault Int
code [Char]
str) = [Char] -> m Value
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Error " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
code [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [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 <- 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
$ [Char] -> HeadersAList -> ByteString -> IO ByteString
post [Char]
url HeadersAList
headers ByteString
req
[Char] -> Err IO MethodResponse
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) Err IO MethodResponse
-> (MethodResponse -> Err IO Value) -> Err IO Value
forall a b.
ExceptT [Char] IO a
-> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
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
[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) Err IO MethodResponse
-> (MethodResponse -> Err IO Value) -> Err IO Value
forall a b.
ExceptT [Char] IO a
-> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
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 :: forall a. Remote a => [Char] -> [Char] -> a
remote [Char]
u [Char]
m = ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ (\[Char]
e -> [Char]
"Error calling " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [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 =
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ (\[Char]
e -> [Char]
"Error calling " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [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 = ([Char] -> IO a) -> Err IO a -> IO a
forall (m :: * -> *) a.
MonadFail m =>
([Char] -> m a) -> Err m a -> m a
handleError ([Char] -> IO a
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO a) -> ([Char] -> [Char]) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
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 a b.
ExceptT [Char] IO a
-> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
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
forall (m :: * -> *). 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 = ([Char] -> [Char]) -> ([Value] -> Err IO Value) -> b
forall a.
Remote a =>
([Char] -> [Char]) -> ([Value] -> Err IO Value) -> a
remote_ [Char] -> [Char]
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 :: [Char] -> HeadersAList -> ByteString -> IO ByteString
post [Char]
url HeadersAList
headers ByteString
content = do
URI
uri <- [Char] -> Maybe URI -> IO URI
forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail ([Char]
"Bad URI: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
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 <- [Char] -> Maybe URIAuth -> IO URIAuth
forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail ([Char]
"Bad URI authority: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show ((URIAuth -> [Char]) -> Maybe URIAuth -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URIAuth -> [Char]
showAuth Maybe URIAuth
a) [Char] -> [Char] -> [Char]
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 "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
u[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
r[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> [Char] -> [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 = 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 = [Char] -> ByteString
BS.pack (URIAuth -> [Char]
uriRegName URIAuth
auth)
port :: a -> a
port a
base = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
base ([Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe a) -> [Char] -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriPort URIAuth
auth)
Connection
c <- case [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriScheme URI
uri of
[Char]
"http" ->
ByteString -> Port -> IO Connection
openConnection ByteString
hostname (Port -> Port
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 (Port -> Port
forall {a}. Read a => a -> a
port Port
443)
[Char]
x -> [Char] -> IO Connection
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unknown scheme: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
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 (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
_ -> [Char] -> IO ByteString
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (Int -> [Char]
forall a. Show a => a -> [Char]
show (Response -> Int
getStatusCode Response
resp) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack (Response -> ByteString
getStatusMessage Response
resp))
Connection -> IO ()
closeConnection Connection
c
ByteString -> IO ByteString
forall a. a -> IO a
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 a. a -> IO a
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 ([Char] -> ByteString
BS.pack ([Char] -> ByteString) -> [Char] -> ByteString
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])
_ -> () -> RequestBuilder ()
forall a. a -> RequestBuilder a
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 [Char], Maybe [Char])
parseUserInfo URIAuth
info = let ([Char]
u,[Char]
pw) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriUserInfo URIAuth
info
in ( if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
u then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
u
, ([Char] -> [Char]
dropAtEnd ([Char] -> [Char])
-> ((Char, [Char]) -> [Char]) -> (Char, [Char]) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ((Char, [Char]) -> [Char]) -> Maybe (Char, [Char]) -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe (Char, [Char])
forall a. [a] -> Maybe (a, [a])
uncons [Char]
pw )
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail :: forall (m :: * -> *) a. MonadFail m => [Char] -> Maybe a -> m a
maybeFail [Char]
msg = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m a
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail [Char]
msg) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
dropAtEnd :: String -> String
dropAtEnd :: [Char] -> [Char]
dropAtEnd [Char]
l = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Char]
l