{-# 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.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

-- | 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)       = 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 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
    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
    parseResponse (BSL.unpack 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) 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

-- | 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) 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


-- | 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 = ([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)

-- | 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 =
    ([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)        -- ^ 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 = ([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))



--
-- 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 <- [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 = URI -> Maybe URIAuth
uriAuthority URI
uri
    auth <- maybeFail ("Bad URI authority: '" ++ show (fmap showAuth a) ++ "'") a
    post_ uri auth headers 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 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 = 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)

    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
            ctx <- IO SSLContext
baselineContextSSL
            openConnectionSSL ctx hostname (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]
"'!")

    req  <- request uri auth headers (BSL.length content)
    body <- inputStreamBody <$> Streams.fromLazyByteString content

    _ <- sendRequest c req body

    s <- receiveResponse c $ \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))

    closeConnection c

    return 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
      res <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
i
      case 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

-- | 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 = 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 )

--
-- Utility functions
--

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