summaryrefslogtreecommitdiff
path: root/examples/raw_call.hs
blob: fbc1777ea3bf8614fab8152123254203ff5b3492 (plain)
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))]