{-# 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 :: MethodResponse -> m Value
handleResponse (Return v :: Value
v)       = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
handleResponse (Fault code :: Int
code str :: String
str) = String -> m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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
forall a. [a] -> [a] -> [a]
++ String
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 :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse
doCall url :: String
url headers :: HeadersAList
headers mc :: 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)

-- | 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 :: String -> String -> [Value] -> Err IO Value
call url :: String
url method :: String
method args :: [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

-- | 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 :: String -> String -> HeadersAList -> [Value] -> Err IO Value
callWithHeaders url :: String
url method :: String
method headers :: HeadersAList
headers args :: [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


-- | 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 :: String -> String -> a
remote u :: String
u m :: String
m = (String -> String) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ (\e :: String
e -> "Error calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e) (String -> String -> [Value] -> Err IO Value
call String
u String
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 :: String -> String -> HeadersAList -> a
remoteWithHeaders u :: String
u m :: String
m headers :: HeadersAList
headers =
    (String -> String) -> ([Value] -> Err IO Value) -> a
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ (\e :: String
e -> "Error calling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " 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)        -- ^ Will be applied to all error
                                         --   messages.
            -> ([Value] -> Err IO Value)
            -> a

instance XmlRpcType a => Remote (IO a) where
    remote_ :: (String -> String) -> ([Value] -> Err IO Value) -> IO a
remote_ h :: String -> String
h f :: [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_ h :: String -> String
h f :: [Value] -> Err IO Value
f x :: a
x = (String -> String) -> ([Value] -> Err IO Value) -> b
forall a.
Remote a =>
(String -> String) -> ([Value] -> Err IO Value) -> a
remote_ String -> String
h (\xs :: [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))



--
-- HTTP functions
--

userAgent :: BS.ByteString
userAgent :: ByteString
userAgent = "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 :: String -> HeadersAList -> ByteString -> IO ByteString
post url :: String
url headers :: HeadersAList
headers content :: ByteString
content = do
    URI
uri <- String -> Maybe URI -> IO URI
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeFail ("Bad URI: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'") (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 ("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]
++ "'") Maybe URIAuth
a
    URI -> URIAuth -> HeadersAList -> ByteString -> IO ByteString
post_ URI
uri URIAuth
auth HeadersAList
headers ByteString
content
  where showAuth :: URIAuth -> String
showAuth (URIAuth u :: String
u r :: String
r p :: String
p) = "URIAuth "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
uString -> String -> String
forall a. [a] -> [a] -> [a]
++" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
rString -> String -> String
forall a. [a] -> [a] -> [a]
++" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
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
uri auth :: URIAuth
auth headers :: HeadersAList
headers content :: 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 base :: 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 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
        "http"  ->
            ByteString -> Port -> IO Connection
openConnection ByteString
hostname (Port -> Port
forall a. Read a => a -> a
port 80)
        "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 443)
        x :: String
x -> String -> IO Connection
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Unknown scheme: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'!")

    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
$ \resp :: Response
resp i :: InputStream ByteString
i -> do
        case Response -> Int
getStatusCode Response
resp of
          200 -> InputStream ByteString -> IO ByteString
readLazyByteString InputStream ByteString
i
          _   -> 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
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 i :: 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
        Nothing -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just bs :: 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

-- | 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
uri auth :: URIAuth
auth usrHeaders :: HeadersAList
usrHeaders len :: 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 "text/xml"
    Int64 -> RequestBuilder ()
setContentLength Int64
len

    case URIAuth -> (Maybe String, Maybe String)
parseUserInfo URIAuth
auth of
      (Just user :: String
user, Just pass :: String
pass) -> ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic (String -> ByteString
BS.pack String
user) (String -> ByteString
BS.pack String
pass)
      _                      -> () -> 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 "User-Agent" ByteString
userAgent

    where
      parseUserInfo :: URIAuth -> (Maybe String, Maybe String)
parseUserInfo info :: URIAuth
info = let (u :: String
u,pw :: 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
==':') (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 )

--
-- Utility functions
--

maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail :: String -> Maybe a -> m a
maybeFail msg :: 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 l :: 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
- 1) String
l