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
|
-- Reads a method call in XML from standard input, sends it to a
-- server and prints the response to standard output. Must be editied
-- to use the right server URL.
import Data.Char
import Network.URI
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)
import Network.XmlRpc.Internals
import Network.HTTP
import Network.Stream
parseArgs :: IO String
parseArgs = do
args <- getArgs
case args of
[url] -> return url
_ -> do
hPutStrLn stderr "Usage: raw_call url"
exitFailure
main = do
url <- parseArgs
c <- getContents
post url c
return ()
userAgent :: String
userAgent = "Haskell XmlRpcClient/0.1"
-- | Handle connection errors.
handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a
handleE h (Left e) = h e
handleE _ (Right v) = return v
post :: String -> String -> IO String
post url content =
case parseURI url of
Nothing -> fail ("Bad uri: '" ++ url ++ "'")
Just uri -> post_ uri content
post_ :: URI -> String -> IO String
post_ uri content =
do
putStrLn "-- Begin request --"
putStrLn (show (request uri content))
putStrLn content
putStrLn "-- End request --"
eresp <- simpleHTTP (request uri content)
resp <- handleE (fail . show) eresp
case rspCode resp of
(2,0,0) -> do
putStrLn "-- Begin response --"
putStrLn (show resp)
putStrLn (rspBody resp)
putStrLn "-- End response --"
return (rspBody resp)
_ -> fail (httpError resp)
where
showRspCode (a,b,c) = map intToDigit [a,b,c]
httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp
-- | Create an XML-RPC compliant HTTP request
request :: URI -> String -> Request String
request uri content = Request{ rqURI = uri,
rqMethod = POST,
rqHeaders = headers,
rqBody = content }
where
-- the HTTP module adds a Host header based on the URI
headers = [Header HdrUserAgent userAgent,
Header HdrContentType "text/xml",
Header HdrContentLength (show (length content))]
|
