1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
{-# 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 (Return v) = return v
handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ 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 url headers mc =
do
let req = renderCall mc
resp <- ioErrorToErr $ post url headers 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 url method args = doCall url [] (MethodCall method args) >>= 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 url method headers args =
doCall url headers (MethodCall method args) >>= 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 u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u 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 u m headers =
remote_ (\e -> "Error calling " ++ m ++ ": " ++ e)
(callWithHeaders u m 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_ h f = handleError (fail . h) $ f [] >>= fromValue
instance (XmlRpcType a, Remote b) => Remote (a -> b) where
remote_ h f x = remote_ h (\xs -> f (toValue x:xs))
--
-- HTTP functions
--
userAgent :: BS.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 url headers content = do
uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url)
let a = uriAuthority uri
auth <- maybeFail ("Bad URI authority: '" ++ show (fmap showAuth a) ++ "'") a
post_ uri auth headers content
where showAuth (URIAuth u r p) = "URIAuth "++u++" "++r++" "++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 auth headers content = withOpenSSL $ do
let hostname = BS.pack (uriRegName auth)
port base = fromMaybe base (readMaybe $ drop 1 $ uriPort auth)
c <- case init $ uriScheme uri of
"http" ->
openConnection hostname (port 80)
"https" -> do
ctx <- baselineContextSSL
openConnectionSSL ctx hostname (port 443)
x -> fail ("Unknown scheme: '" ++ x ++ "'!")
req <- request uri auth headers (BSL.length content)
body <- inputStreamBody <$> Streams.fromLazyByteString content
_ <- sendRequest c req body
s <- receiveResponse c $ \resp i -> do
case getStatusCode resp of
200 -> readLazyByteString i
_ -> fail (show (getStatusCode resp) ++ " " ++ BS.unpack (getStatusMessage resp))
closeConnection c
return s
readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString
readLazyByteString i = BSL.fromChunks <$> go
where
go :: IO [BS.ByteString]
go = do
res <- Streams.read i
case res of
Nothing -> return []
Just bs -> (bs:) <$> go
-- | Create an XML-RPC compliant HTTP request.
request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request
request uri auth usrHeaders len = buildRequest $ do
http POST (BS.pack $ uriPath uri)
setContentType "text/xml"
setContentLength len
case parseUserInfo auth of
(Just user, Just pass) -> setAuthorizationBasic (BS.pack user) (BS.pack pass)
_ -> return ()
mapM_ (uncurry setHeader) usrHeaders
setHeader "User-Agent" userAgent
where
parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info
in ( if null u then Nothing else Just u
, (dropAtEnd . snd) <$> uncons pw )
--
-- Utility functions
--
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail msg = maybe (Fail.fail msg) return
dropAtEnd :: String -> String
dropAtEnd l = take (length l - 1) l
|
