{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XmlRpc.Client
-- Copyright   :  (c) Bjorn Bringert 2003
-- License     :  BSD-style
--
-- Maintainer  :  bjorn@bringert.net
-- Stability   :  experimental
-- Portability :  non-portable (requires extensions and non-portable libraries)
--
-- This module contains the client functionality of XML-RPC.
-- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.
--
-- A simple client application:
--
-- > import Network.XmlRpc.Client
-- >
-- > server = "http://localhost/~bjorn/cgi-bin/simple_server"
-- >
-- > add :: String -> Int -> Int -> IO Int
-- > add url = remote url "examples.add"
-- >
-- > main = do
-- >        let x = 4
-- >            y = 7
-- >        z <- add server x y
-- >        putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z)
--
-----------------------------------------------------------------------------

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

-- | Gets the return value from a method response.
--   Throws an exception if the response was a fault.
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 HeadersAList = [(BS.ByteString, BS.ByteString)]

-- | Sends a method call to a server and returns the response.
--   Throws an exception if the response was an error.
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)

-- | Low-level method calling function. Use this function if
--   you need to do custom conversions between XML-RPC types and
--   Haskell types.
--   Throws an exception if the response was a fault.
call :: String -- ^ URL for the XML-RPC server.
     -> String -- ^ Method name.
     -> [Value] -- ^ The arguments.
     -> Err IO Value -- ^ The result
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

-- | Low-level method calling function. Use this function if
--   you need to do custom conversions between XML-RPC types and
--   Haskell types. Takes a list of extra headers to add to the
--   HTTP request.
--   Throws an exception if the response was a fault.
callWithHeaders :: String -- ^ URL for the XML-RPC server.
                -> String -- ^ Method name.
                -> HeadersAList -- ^ Extra headers to add to HTTP request.
                -> [Value] -- ^ The arguments.
                -> Err IO Value -- ^ The result
callWithHeaders :: [Char] -> [Char] -> HeadersAList -> [Value] -> Err IO Value
callWithHeaders [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


-- | Call a remote method.
remote :: Remote a =>
          String -- ^ Server URL. May contain username and password on
                 --   the format username:password\@ before the hostname.
       -> String -- ^ Remote method name.
       -> a      -- ^ Any function
                 -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
                 -- t1 -> ... -> tn -> IO r@
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)

-- | Call a remote method. Takes a list of extra headers to add to the HTTP
--   request.
remoteWithHeaders :: Remote a =>
                     String   -- ^ Server URL. May contain username and password on
                              --   the format username:password\@ before the hostname.
                  -> String   -- ^ Remote method name.
                  -> HeadersAList -- ^ Extra headers to add to HTTP request.
                  -> a        -- ^ Any function
                              -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
                              -- t1 -> ... -> tn -> IO r@
remoteWithHeaders :: forall a. Remote a => [Char] -> [Char] -> HeadersAList -> a
remoteWithHeaders [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)        -- ^ Will be applied to all error
                                         --   messages.
            -> ([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))



--
-- HTTP functions
--

userAgent :: BS.ByteString
userAgent :: ByteString
userAgent = ByteString
"Haskell XmlRpcClient/0.1"

-- | Post some content to a uri, return the content of the response
--   or an error.
-- FIXME: should we really use fail?

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 some content to a uri, return the content of the response
--   or an error.
-- FIXME: should we really use fail?
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

-- | Create an XML-RPC compliant HTTP request.
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 )

--
-- Utility functions
--

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