haxr (empty) → 3000.0.0
raw patch · 9 files changed
+1548/−0 lines, 9 filesdep +HTTPdep +HaXmldep +basebuild-type:Customsetup-changed
Dependencies added: HTTP, HaXml, base, mtl, network
Files
- LICENSE +21/−0
- Network/XmlRpc/Base64.hs +282/−0
- Network/XmlRpc/Client.hs +177/−0
- Network/XmlRpc/DTD_XMLRPC.hs +296/−0
- Network/XmlRpc/Internals.hs +548/−0
- Network/XmlRpc/Introspect.hs +31/−0
- Network/XmlRpc/Server.hs +162/−0
- Setup.lhs +8/−0
- haxr.cabal +23/−0
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2003-2005 Bjorn Bringert. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++This software is provided by the copyright holders "as is" and any express or+implied warranties, including, but not limited to, the implied warranties of+merchantability and fitness for a particular purpose are disclaimed. In no+event shall the copyright holders be liable for any direct, indirect,+incidental, special, exemplary, or consequential damages (including, but not+limited to, procurement of substitute goods or services; loss of use, data,+or profits; or business interruption) however caused and on any theory of+liability, whether in contract, strict liability, or tort (including+negligence or otherwise) arising in any way out of the use of this software,+even if advised of the possibility of such damage.
+ Network/XmlRpc/Base64.hs view
@@ -0,0 +1,282 @@+-----------------------------------------------------------------------------+-- |+-- Module : Codec.Binary.Base64+-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002+-- License : BSD-style (see the file ReadMe.tex)+--+-- Maintainer : dominic.steinitz@blueyonder.co.uk+-- Stability : experimental+-- Portability : portable+--+-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Network.XmlRpc.Base64 (+ encode,+ decode,+ chop72+) where++++{------------------------------------------------------------------------+This is what RFC2045 had to say:++6.8. Base64 Content-Transfer-Encoding++ The Base64 Content-Transfer-Encoding is designed to represent+ arbitrary sequences of octets in a form that need not be humanly+ readable. The encoding and decoding algorithms are simple, but the+ encoded data are consistently only about 33 percent larger than the+ unencoded data. This encoding is virtually identical to the one used+ in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.++ A 65-character subset of US-ASCII is used, enabling 6 bits to be+ represented per printable character. (The extra 65th character, "=",+ is used to signify a special processing function.)++ NOTE: This subset has the important property that it is represented+ identically in all versions of ISO 646, including US-ASCII, and all+ characters in the subset are also represented identically in all+ versions of EBCDIC. Other popular encodings, such as the encoding+ used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and+ the base85 encoding specified as part of Level 2 PostScript, do not+ share these properties, and thus do not fulfill the portability+ requirements a binary transport encoding for mail must meet.++ The encoding process represents 24-bit groups of input bits as output+ strings of 4 encoded characters. Proceeding from left to right, a+ 24-bit input group is formed by concatenating 3 8bit input groups.+ These 24 bits are then treated as 4 concatenated 6-bit groups, each+ of which is translated into a single digit in the base64 alphabet.+ When encoding a bit stream via the base64 encoding, the bit stream+ must be presumed to be ordered with the most-significant-bit first.+ That is, the first bit in the stream will be the high-order bit in+ the first 8bit byte, and the eighth bit will be the low-order bit in+ the first 8bit byte, and so on.++ Each 6-bit group is used as an index into an array of 64 printable+ characters. The character referenced by the index is placed in the+ output string. These characters, identified in Table 1, below, are+ selected so as to be universally representable, and the set excludes+ characters with particular significance to SMTP (e.g., ".", CR, LF)+ and to the multipart boundary delimiters defined in RFC 2046 (e.g.,+ "-").++++ Table 1: The Base64 Alphabet++ Value Encoding Value Encoding Value Encoding Value Encoding+ 0 A 17 R 34 i 51 z+ 1 B 18 S 35 j 52 0+ 2 C 19 T 36 k 53 1+ 3 D 20 U 37 l 54 2+ 4 E 21 V 38 m 55 3+ 5 F 22 W 39 n 56 4+ 6 G 23 X 40 o 57 5+ 7 H 24 Y 41 p 58 6+ 8 I 25 Z 42 q 59 7+ 9 J 26 a 43 r 60 8+ 10 K 27 b 44 s 61 9+ 11 L 28 c 45 t 62 ++ 12 M 29 d 46 u 63 /+ 13 N 30 e 47 v+ 14 O 31 f 48 w (pad) =+ 15 P 32 g 49 x+ 16 Q 33 h 50 y++ The encoded output stream must be represented in lines of no more+ than 76 characters each. All line breaks or other characters not+ found in Table 1 must be ignored by decoding software. In base64+ data, characters other than those in Table 1, line breaks, and other+ white space probably indicate a transmission error, about which a+ warning message or even a message rejection might be appropriate+ under some circumstances.++ Special processing is performed if fewer than 24 bits are available+ at the end of the data being encoded. A full encoding quantum is+ always completed at the end of a body. When fewer than 24 input bits+ are available in an input group, zero bits are added (on the right)+ to form an integral number of 6-bit groups. Padding at the end of+ the data is performed using the "=" character. Since all base64+ input is an integral number of octets, only the following cases can+ arise: (1) the final quantum of encoding input is an integral+ multiple of 24 bits; here, the final unit of encoded output will be+ an integral multiple of 4 characters with no "=" padding, (2) the+ final quantum of encoding input is exactly 8 bits; here, the final+ unit of encoded output will be two characters followed by two "="+ padding characters, or (3) the final quantum of encoding input is+ exactly 16 bits; here, the final unit of encoded output will be three+ characters followed by one "=" padding character.++ Because it is used only for padding at the end of the data, the+ occurrence of any "=" characters may be taken as evidence that the+ end of the data has been reached (without truncation in transit). No+ such assurance is possible, however, when the number of octets+ transmitted was a multiple of three and no "=" characters are+ present.++ Any characters outside of the base64 alphabet are to be ignored in+ base64-encoded data.++ Care must be taken to use the proper octets for line breaks if base64+ encoding is applied directly to text material that has not been+ converted to canonical form. In particular, text line breaks must be+ converted into CRLF sequences prior to base64 encoding. The+ important thing to note is that this may be done directly by the+ encoder rather than in a prior canonicalization step in some+ implementations.++ NOTE: There is no need to worry about quoting potential boundary+ delimiters within base64-encoded bodies within multipart entities+ because no hyphen characters are used in the base64 encoding.+++----------------------------------------------------------------------------}+++{-++The following properties should hold:++ decode . encode = id+ decode . chop72 . encode = id++I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,+the second variation corresponds better with the RFC above, but outside of+MIME applications might be undesireable.++++But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-}+++++import Data.Array+import Data.Bits+import Data.Int+import Data.Char (chr,ord)+import Data.Word (Word8)++encodeArray :: Array Int Char+encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')+ , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')+ , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')+ , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')+ , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')+ , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')+ , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')+ , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')+ , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]+++-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)+-- clearly the upmost/leftmost 8 bits of the answer are 0.+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.+-- 0 represents a 4 :(+int4_char3 :: [Int] -> [Char]+int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)+ in (chr (n `shiftR` 16 .&. 0xff))+ : (chr (n `shiftR` 8 .&. 0xff))+ : (chr (n .&. 0xff)) : int4_char3 t++int4_char3 [a,b,c] =+ let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)+ in [ (chr (n `shiftR` 16 .&. 0xff))+ , (chr (n `shiftR` 8 .&. 0xff)) ]++int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12)+ in [ (chr (n `shiftR` 16 .&. 0xff)) ]++int4_char3 [] = [] +++++-- Convert triplets of characters to+-- 4 base64 integers. The last entries+-- in the list may not produce 4 integers,+-- a trailing 2 character group gives 3 integers,+-- while a trailing single character gives 2 integers.+char3_int4 :: [Char] -> [Int]+char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)+ in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t++char3_int4 [a,b]+ = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)+ in [ (n `shiftR` 18 .&. 0x3f)+ , (n `shiftR` 12 .&. 0x3f)+ , (n `shiftR` 6 .&. 0x3f) ]+ +char3_int4 [a]+ = let n = (ord a `shiftL` 16)+ in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]++char3_int4 [] = []+++-- Retrieve base64 char, given an array index integer in the range [0..63]+enc1 :: Int -> Char+enc1 ch = encodeArray!ch+++-- | Cut up a string into 72 char lines, each line terminated by CRLF.++chop72 :: String -> String+chop72 str = let (bgn,end) = splitAt 70 str+ in if null end then bgn else "\r\n" ++ chop72 end+++-- Pads a base64 code to a multiple of 4 characters, using the special+-- '=' character.+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t+quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit+quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit+quadruplets [] = [] -- 24bit tail unit+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++dcd [] = []+dcd (h:t)+ | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t+ | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t+ | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t+ | h == '+' = 62 : dcd t+ | h == '/' = 63 : dcd t+ | h == '=' = [] -- terminate data stream+ | otherwise = dcd t+++-- Principal encoding and decoding functions.++encode :: [Word8] -> String+encode = enc . char3_int4 . (map (chr .fromIntegral))++{-+prop_base64 os =+ os == (f . g . h) os+ where types = (os :: [Word8])+ f = map (fromIntegral. ord)+ g = decode . encode+ h = map (chr . fromIntegral)+-}++decode :: String -> [Word8]+decode = (map (fromIntegral . ord)) . int4_char3 . dcd
+ Network/XmlRpc/Client.hs view
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- 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,+ call,+ Remote+ ) where++import Network.XmlRpc.Base64 as Base64+import Network.XmlRpc.Internals++import Control.Exception (handleJust, userErrors)+import Data.Char+import Data.Maybe+import Data.Word (Word8)+import Network.URI+import Network.Socket (withSocketsDo)++import Network.HTTP+++-- | Gets the return value from a method response.+-- Throws an exception if the response was a fault.+handleResponse :: Monad m => MethodResponse -> m Value+handleResponse (Return v) = return v+handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ str)++-- | Sends a method call to a server and returns the response.+-- Throws an exception if the response was an error.+doCall :: String -> MethodCall -> Err IO MethodResponse+doCall url mc = + do + let req = renderCall mc+ --FIXME: remove+ --putStrLn req+ resp <- ioErrorToErr $ post url req+ --FIXME: remove+ --putStrLn resp+ parseResponse 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+++-- | 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)++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 :: 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 some content to a uri, return the content of the response+-- or an error.+-- FIXME: should we really use fail?+post :: String -> String -> IO String+post url content = do+ uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url)+ let a = authority uri+ auth <- maybeFail ("Bad URI authority: '" ++ a ++ "'") (parseURIAuthority a)+ post_ uri auth content++-- | Post some content to a uri, return the content of the response+-- or an error.+-- FIXME: should we really use fail?+post_ :: URI -> URIAuthority -> String -> IO String+post_ uri auth content = + do+ -- FIXME: remove+ --putStrLn (show (request uri content))+ --putStrLn content+ eresp <- simpleHTTP (request uri auth content)+ resp <- handleE (fail . show) eresp+ case rspCode resp of+ (2,0,0) -> 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 -> URIAuthority -> String -> Request+request uri auth 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)) + ] ++ maybeToList (authHdr (user auth) (password auth))++-- | Creates an Authorization header using the Basic scheme, +-- see RFC 2617 section 2.+authHdr :: Maybe String -- ^ User name, if any+ -> Maybe String -- ^ Password, if any+ -> Maybe Header -- ^ If user name or password was given, returns + -- an Authorization header, otherwise 'Nothing'+authHdr Nothing Nothing = Nothing+authHdr u p = Just (Header HdrAuthorization ("Basic " ++ base64encode user_pass))+ where user_pass = fromMaybe "" u ++ ":" ++ fromMaybe "" p+ base64encode = encode . stringToOctets+ -- FIXME: this probably only works right for latin-1 strings+ stringToOctets :: String -> [Word8]+ stringToOctets = map (fromIntegral . fromEnum)++--+-- Utility functions+--++maybeFail :: Monad m => String -> Maybe a -> m a+maybeFail msg = maybe (fail msg) return
+ Network/XmlRpc/DTD_XMLRPC.hs view
@@ -0,0 +1,296 @@+module Network.XmlRpc.DTD_XMLRPC where++import Text.XML.HaXml.Xml2Haskell+import Text.XML.HaXml.OneOfN+import Data.Char (isSpace)+import Prelude (all, concatMap, (++), maybe)+import qualified Prelude+++{-Type decls-}++newtype I4 = I4 Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype Int = Int Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype Boolean = Boolean Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype String = String Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype Double = Double Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype DateTime_iso8601 = DateTime_iso8601 Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype Base64 = Base64 Prelude.String deriving (Prelude.Eq,Prelude.Show)+newtype Data = Data [Value] deriving (Prelude.Eq,Prelude.Show)+newtype Array = Array Data deriving (Prelude.Eq,Prelude.Show)+newtype Name = Name Prelude.String deriving (Prelude.Eq,Prelude.Show)+data Member = Member Name Value+ deriving (Prelude.Eq,Prelude.Show)+newtype Struct = Struct [Member] deriving (Prelude.Eq,Prelude.Show)+newtype Value = Value [Value_] deriving (Prelude.Eq,Prelude.Show)+data Value_ = Value_Str Prelude.String+ | Value_I4 I4+ | Value_Int Int+ | Value_Boolean Boolean+ | Value_String String+ | Value_DateTime_iso8601 DateTime_iso8601+ | Value_Double Double+ | Value_Base64 Base64+ | Value_Struct Struct+ | Value_Array Array+ deriving (Prelude.Eq,Prelude.Show)+newtype Param = Param Value deriving (Prelude.Eq,Prelude.Show)+newtype Params = Params [Param] deriving (Prelude.Eq,Prelude.Show)+newtype MethodName = MethodName Prelude.String deriving (Prelude.Eq,Prelude.Show)+data MethodCall = MethodCall MethodName (Prelude.Maybe Params)+ deriving (Prelude.Eq,Prelude.Show)+newtype Fault = Fault Value deriving (Prelude.Eq,Prelude.Show)+data MethodResponse = MethodResponseParams Params+ | MethodResponseFault Fault+ deriving (Prelude.Eq,Prelude.Show)+++{-Instance decls-}++instance XmlContent I4 where+ fromElem (CElem (Elem "i4" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (I4 a), rest))+ (definite fromText "text" "i4" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (I4 a) =+ [CElem (Elem "i4" [] (toText a))]+instance XmlContent Int where+ fromElem (CElem (Elem "int" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Int a), rest))+ (definite fromText "text" "int" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Int a) =+ [CElem (Elem "int" [] (toText a))]+instance XmlContent Boolean where+ fromElem (CElem (Elem "boolean" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Boolean a), rest))+ (definite fromText "text" "boolean" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Boolean a) =+ [CElem (Elem "boolean" [] (toText a))]+instance XmlContent String where+ fromElem (CElem (Elem "string" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (String a), rest))+ (definite fromText "text" "string" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (String a) =+ [CElem (Elem "string" [] (toText a))]+instance XmlContent Double where+ fromElem (CElem (Elem "double" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Double a), rest))+ (definite fromText "text" "double" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Double a) =+ [CElem (Elem "double" [] (toText a))]+instance XmlContent DateTime_iso8601 where+ fromElem (CElem (Elem "dateTime.iso8601" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (DateTime_iso8601 a), rest))+ (definite fromText "text" "dateTime.iso8601" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (DateTime_iso8601 a) =+ [CElem (Elem "dateTime.iso8601" [] (toText a))]+instance XmlContent Base64 where+ fromElem (CElem (Elem "base64" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Base64 a), rest))+ (definite fromText "text" "base64" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Base64 a) =+ [CElem (Elem "base64" [] (toText a))]+instance XmlContent Data where+ fromElem (CElem (Elem "data" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Data a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Data a) =+ [CElem (Elem "data" [] (concatMap toElem a))]+instance XmlContent Array where+ fromElem (CElem (Elem "array" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Array a), rest))+ (definite fromElem "<data>" "array" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Array a) =+ [CElem (Elem "array" [] (toElem a))]+instance XmlContent Name where+ fromElem (CElem (Elem "name" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Name a), rest))+ (definite fromText "text" "name" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Name a) =+ [CElem (Elem "name" [] (toText a))]+instance XmlContent Member where+ fromElem (CElem (Elem "member" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Prelude.Just (Member a b), rest))+ (definite fromElem "<value>" "member" ca))+ (definite fromElem "<name>" "member" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Member a b) =+ [CElem (Elem "member" [] (toElem a ++ toElem b))]+instance XmlContent Struct where+ fromElem (CElem (Elem "struct" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Struct a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Struct a) =+ [CElem (Elem "struct" [] (concatMap toElem a))]+instance XmlContent Value where+ fromElem (CElem (Elem "value" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Value a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Value a) =+ [CElem (Elem "value" [] (concatMap toElem a))]+instance XmlContent Value_ where+ fromElem c0 =+ case (fromText c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Str a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_I4 a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Int a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Boolean a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_String a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_DateTime_iso8601 a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Double a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Base64 a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Struct a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,rest) -> (Prelude.Just (Value_Array a), rest)+ (_,_) ->+ (Prelude.Nothing, c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Value_Str a) = toText a+ toElem (Value_I4 a) = toElem a+ toElem (Value_Int a) = toElem a+ toElem (Value_Boolean a) = toElem a+ toElem (Value_String a) = toElem a+ toElem (Value_DateTime_iso8601 a) = toElem a+ toElem (Value_Double a) = toElem a+ toElem (Value_Base64 a) = toElem a+ toElem (Value_Struct a) = toElem a+ toElem (Value_Array a) = toElem a+instance XmlContent Param where+ fromElem (CElem (Elem "param" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Param a), rest))+ (definite fromElem "<value>" "param" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Param a) =+ [CElem (Elem "param" [] (toElem a))]+instance XmlContent Params where+ fromElem (CElem (Elem "params" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Params a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Params a) =+ [CElem (Elem "params" [] (concatMap toElem a))]+instance XmlContent MethodName where+ fromElem (CElem (Elem "methodName" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (MethodName a), rest))+ (definite fromText "text" "methodName" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (MethodName a) =+ [CElem (Elem "methodName" [] (toText a))]+instance XmlContent MethodCall where+ fromElem (CElem (Elem "methodCall" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Prelude.Just (MethodCall a b), rest))+ (fromElem ca))+ (definite fromElem "<methodName>" "methodCall" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (MethodCall a b) =+ [CElem (Elem "methodCall" [] (toElem a ++ maybe [] toElem b))]+instance XmlContent Fault where+ fromElem (CElem (Elem "fault" [] c0):rest) =+ (\(a,ca)->+ (Prelude.Just (Fault a), rest))+ (definite fromElem "<value>" "fault" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (Fault a) =+ [CElem (Elem "fault" [] (toElem a))]+instance XmlContent MethodResponse where+ fromElem (CElem (Elem "methodResponse" [] c0):rest) =+ case (fromElem c0) of+ (Prelude.Just a,_) -> (Prelude.Just (MethodResponseParams a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Prelude.Just a,_) -> (Prelude.Just (MethodResponseFault a), rest)+ (_,_) ->+ (Prelude.Nothing, c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Prelude.Nothing, rest)+ toElem (MethodResponseParams a) = [CElem (Elem "methodResponse" [] (toElem a) )]+ toElem (MethodResponseFault a) = [CElem (Elem "methodResponse" [] (toElem a) )]+++{-Done-}
+ Network/XmlRpc/Internals.hs view
@@ -0,0 +1,548 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XmlRpc.Internals+-- 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 core functionality of the XML-RPC library. +-- Most applications should not need to use this module. Client+-- applications should use "XmlRpcClient" and server applications should+-- use "XmlRpcServer".+--+-- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.+--+-----------------------------------------------------------------------------++module Network.XmlRpc.Internals (+-- * Method calls and repsonses+MethodCall(..), MethodResponse(..),+-- * XML-RPC types+Value(..), Type(..), XmlRpcType(..),+-- * Converting from XML +parseResponse, parseCall, getField, getFieldMaybe,+-- * Converting to XML +renderCall, renderResponse,+-- * Error monad+Err, maybeToM, handleError, ioErrorToErr+) where++import Prelude hiding (showString, catch)+import Control.Monad+import Data.Maybe+import Data.List+import Data.Word (Word8)+import Numeric (showFFloat)+import Data.Char+import System.Time+import System.Locale+import Control.Exception+import Control.Monad.Error+import Control.Monad.Identity+import System.IO.Unsafe (unsafePerformIO)++import Text.XML.HaXml.Xml2Haskell++import Network.XmlRpc.Base64 as Base64+import qualified Network.XmlRpc.DTD_XMLRPC as XR++--+-- General utilities+--++-- | Replaces all occurances of a sublist in a list with another list.+-- If the list to replace is the empty list, does nothing.+replace :: Eq a => + [a] -- ^ The sublist to replace when found+ -> [a] -- ^ The list to replace it with+ -> [a] -- ^ The list to replace in+ -> [a] -- ^ The result+replace [] _ xs = xs+replace _ _ [] = []+replace ys zs xs@(x:xs')+ | isPrefixOf ys xs = zs ++ replace ys zs (drop (length ys) xs)+ | otherwise = x : replace ys zs xs'++-- | Convert a 'Maybe' value to a value in any monad+maybeToM :: Monad m => + String -- ^ Error message to fail with for 'Nothing'+ -> Maybe a -- ^ The 'Maybe' value.+ -> m a -- ^ The resulting value in the monad.+maybeToM err Nothing = fail err+maybeToM _ (Just x) = return x++--+-- Error monad stuff+--++type Err m a = ErrorT String m a++-- | Evaluate the argument and catch error call exceptions+errorToErr :: Monad m => a -> Err m a+errorToErr x = let e = unsafePerformIO (tryJust errorCalls (evaluate x))+ in ErrorT (return e)++-- | Catch IO errors in the error monad.+ioErrorToErr :: IO a -> Err IO a+ioErrorToErr = ErrorT . liftM (either (Left . show) Right) . tryJust ioErrors+++-- | Handle errors from the error monad.+handleError :: Monad m => (String -> m a) -> Err m a -> m a+handleError h m = do + Right x <- runErrorT (catchError m (lift . h))+ return x++errorRead :: (Monad m, Read a) => + ReadS a -- ^ Parser+ -> String -- ^ Error message+ -> String -- ^ String to parse+ -> Err m a+errorRead r err s = case [x | (x,t) <- r s, ("","") <- lex t] of+ [x] -> return x+ _ -> fail (err ++ ": '" ++ s ++ "'")++-- | Convert an 'Int' to some instance of 'Enum', and fail if the +-- 'Int' is out of range.+errorToEnum :: (Monad m, Bounded a, Enum a) => + String -- ^ Error message+ -> Int+ -> Err m a+errorToEnum err x | x < fromEnum (minBound `asTypeOf` r) = fail err+ | x > fromEnum (maxBound `asTypeOf` r) = fail err+ | otherwise = return r+ where r = toEnum x++--+-- Types for methods calls and responses+--++-- | An XML-RPC method call. Consists of a method name and a list of +-- parameters.+data MethodCall = MethodCall String [Value]+ deriving (Eq, Show) -- for debugging ++-- | An XML-RPC response.+data MethodResponse = Return Value -- ^ A method response returning a value+ | Fault Int String -- ^ A fault response+ deriving (Eq, Show) -- for debugging ++-- | An XML-RPC value.+data Value = + ValueInt Int -- ^ int or i4+ | ValueBool Bool -- ^ bool+ | ValueString String -- ^ string+ | ValueDouble Double -- ^ double+ | ValueDateTime CalendarTime -- ^ dateTime.iso8601+ | ValueBase64 String -- ^ base 64+ | ValueStruct [(String,Value)] -- ^ struct+ | ValueArray [Value] -- ^ array+ deriving (Eq, Show) -- for debugging ++-- | An XML-RPC value. Use for error messages and introspection.+data Type = + TInt+ | TBool+ | TString+ | TDouble+ | TDateTime+ | TBase64+ | TStruct+ | TArray+ | TUnknown+ deriving (Eq)++instance Show Type where+ show TInt = "int"+ show TBool = "bool"+ show TString = "string"+ show TDouble = "double"+ show TDateTime = "dateTime.iso8601"+ show TBase64 = "base64"+ show TStruct = "struct"+ show TArray = "array"+ show TUnknown = "unknown"++instance Read Type where+ readsPrec _ s = case break isSpace (dropWhile isSpace s) of+ ("int",r) -> [(TInt,r)]+ ("bool",r) -> [(TBool,r)]+ ("string",r) -> [(TString,r)]+ ("double",r) -> [(TDouble,r)]+ ("dateTime.iso8601",r) -> [(TDateTime,r)]+ ("base64",r) -> [(TBase64,r)]+ ("struct",r) -> [(TStruct,r)]+ ("array",r) -> [(TArray,r)]++-- | Gets the value of a struct member+structGetValue :: Monad m => String -> Value -> Err m Value+structGetValue n (ValueStruct t) = + maybeToM ("Unknown member '" ++ n ++ "'") (lookup n t)+structGetValue _ _ = fail "Value is not a struct"++-- | Builds a fault struct +faultStruct :: Int -> String -> Value+faultStruct code str = ValueStruct [("faultCode",ValueInt code),+ ("faultString",ValueString str)]++-- XML-RPC specification:+-- "The body of the response is a single XML structure, a+-- <methodResponse>, which can contain a single <params> which contains a+-- single <param> which contains a single <value>."+onlyOneResult :: Monad m => [Value] -> Err m Value +onlyOneResult [] = fail "Method returned no result" +onlyOneResult [x] = return x +onlyOneResult _ = fail "Method returned more than one result"++--+-- Converting to and from XML-RPC types+--++-- | A class for mapping Haskell types to XML-RPC types.+class XmlRpcType a where+ -- | Convert from this type to a 'Value'+ toValue :: a -> Value+ -- | Convert from a 'Value' to this type. May fail if+ -- if there is a type error.+ fromValue :: Monad m => Value -> Err m a+ getType :: a -> Type++typeError :: Monad m => Type -> Value -> Err m a+typeError t v = fail ("Wanted: " + -- ++ show (getType t)+ ++ "', got: '" + ++ showXml (toXRValue v) ++ "'")+++simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a) + -> Value -> Err m a+simpleFromValue f v = + maybe (typeError (getType (fromJust (f v))) v) return (f v)+++-- | Exists to allow explicit type conversions.+instance XmlRpcType Value where+ toValue = id+ fromValue = return . id+ getType _ = TUnknown++-- FIXME: instance for ()?+++instance XmlRpcType Int where+ toValue = ValueInt+ fromValue = simpleFromValue f+ where f (ValueInt x) = Just x+ f _ = Nothing+ getType _ = TInt++instance XmlRpcType Bool where+ toValue = ValueBool+ fromValue = simpleFromValue f+ where f (ValueBool x) = Just x+ f _ = Nothing+ getType _ = TBool++instance XmlRpcType String where+ toValue = ValueString+ fromValue = simpleFromValue f+ where f (ValueString x) = Just x+ f (ValueBase64 x) = Just x+ f _ = Nothing+ getType _ = TString++instance XmlRpcType Double where+ toValue = ValueDouble+ fromValue = simpleFromValue f+ where f (ValueDouble x) = Just x+ f _ = Nothing+ getType _ = TDouble++instance XmlRpcType CalendarTime where+ toValue = ValueDateTime+ fromValue = simpleFromValue f+ where f (ValueDateTime x) = Just x+ f _ = Nothing+ getType _ = TDateTime++-- FIXME: array elements may have different types+instance XmlRpcType a => XmlRpcType [a] where+ toValue = ValueArray . map toValue + fromValue v = case v of+ ValueArray _ -> r+ -- FIXME: I am using TArray here because for+ -- some reason Hugs Nov 2003 requires a XmlRpcRpc [a]+ -- constraint on fromValue (which is not + -- legal haskell) to do (getType t) here.+ _ -> r >>= \t -> typeError TArray v+ where ValueArray xs = v+ r = mapM fromValue xs+ getType _ = TArray++-- FIXME: struct elements may have different types+instance XmlRpcType a => XmlRpcType [(String,a)] where+ toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs]++ fromValue v = case v of+ ValueStruct _ -> r+ _ -> r >>= \t -> typeError (getType t) v+ where ValueStruct xs = v+ r = mapM (\ (n,v) -> liftM ((,) n) (fromValue v)) xs+ getType _ = TStruct++-- | Get a field value from a (possibly heterogeneous) struct.+getField :: (Monad m, XmlRpcType a) => + String -- ^ Field name+ -> [(String,Value)] -- ^ Struct+ -> Err m a+getField x xs = maybeToM ("struct member " ++ show x ++ " not found") + (lookup x xs) >>= fromValue++-- | Get a field value from a (possibly heterogeneous) struct.+getFieldMaybe :: (Monad m, XmlRpcType a) => + String -- ^ Field name+ -> [(String,Value)] -- ^ Struct+ -> Err m (Maybe a)+getFieldMaybe x xs = case lookup x xs of + Nothing -> return Nothing+ Just v -> liftM Just (fromValue v)++--+-- Converting to XR types+--++toXRValue :: Value -> XR.Value+toXRValue (ValueInt x) = XR.Value [XR.Value_Int (XR.Int (showInt x))]+toXRValue (ValueBool b) = XR.Value [XR.Value_Boolean (XR.Boolean (showBool b))]+toXRValue (ValueString s) = XR.Value [XR.Value_String (XR.String (showString s))]+toXRValue (ValueDouble d) = XR.Value [XR.Value_Double (XR.Double (showDouble d))]+toXRValue (ValueDateTime t) = + XR.Value [ XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 (showDateTime t))]+toXRValue (ValueBase64 s) = XR.Value [XR.Value_Base64 (XR.Base64 (showBase64 s))]+toXRValue (ValueStruct xs) = XR.Value [XR.Value_Struct (XR.Struct (map toXRMember xs))]+toXRValue (ValueArray xs) = + XR.Value [XR.Value_Array (XR.Array (XR.Data (map toXRValue xs)))]++showInt :: Int -> String+showInt = show++showBool :: Bool -> String+showBool b = if b then "1" else "0"++-- escapes & and <+showString :: String -> String+showString s = replace "<" "<" (replace "&" "&" s)++-- | Shows a double in signed decimal point notation.+showDouble :: Double -> String+showDouble d = showFFloat Nothing d ""++-- | Shows a date and time on the format: YYYYMMDDTHH:mm:SS+showDateTime :: CalendarTime -> String+showDateTime t = formatCalendarTime defaultTimeLocale xmlRpcDateFormat t+ where xmlRpcDateFormat = "%Y%m%dT%H:%M:%S"++showBase64 :: String -> String+showBase64 = encode . stringToOctets+ where+ -- FIXME: this probably only works right for latin-1 strings+ stringToOctets :: String -> [Word8]+ stringToOctets = map (fromIntegral . fromEnum)+++toXRMethodCall :: MethodCall -> XR.MethodCall+toXRMethodCall (MethodCall name vs) = + XR.MethodCall (XR.MethodName name) (Just (toXRParams vs))++toXRMethodResponse :: MethodResponse -> XR.MethodResponse+toXRMethodResponse (Return val) = XR.MethodResponseParams (toXRParams [val])+toXRMethodResponse (Fault code str) = + XR.MethodResponseFault (XR.Fault (toXRValue (faultStruct code str)))++toXRParams :: [Value] -> XR.Params +toXRParams vs = XR.Params (map (XR.Param . toXRValue) vs)++toXRMember :: (String, Value) -> XR.Member+toXRMember (n, v) = XR.Member (XR.Name n) (toXRValue v)++--+-- Converting from XR types+--++fromXRValue :: Monad m => XR.Value -> Err m Value+fromXRValue (XR.Value vs)+ = case (filter notstr vs) of+ [] -> liftM (ValueString . concat) (mapM (readString . unstr) vs)+ (v:_) -> f v+ where+ notstr (XR.Value_Str _) = False+ notstr _ = True++ unstr (XR.Value_Str x) = x++ f (XR.Value_I4 (XR.I4 x)) = liftM ValueInt (readInt x)+ f (XR.Value_Int (XR.Int x)) = liftM ValueInt (readInt x)+ f (XR.Value_Boolean (XR.Boolean x)) = liftM ValueBool (readBool x)+ f (XR.Value_Double (XR.Double x)) = liftM ValueDouble (readDouble x)+ f (XR.Value_String (XR.String x)) = liftM ValueString (readString x)+ f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 x)) =+ liftM ValueDateTime (readDateTime x)+ f (XR.Value_Base64 (XR.Base64 x)) = liftM ValueBase64 (readBase64 x)+ f (XR.Value_Struct (XR.Struct ms)) = + liftM ValueStruct (mapM fromXRMember ms) + f (XR.Value_Array (XR.Array (XR.Data xs))) = + liftM ValueArray (mapM fromXRValue xs) +++fromXRMember :: Monad m => XR.Member -> Err m (String,Value)+fromXRMember (XR.Member (XR.Name n) xv) = liftM (\v -> (n,v)) (fromXRValue xv)++-- | From the XML-RPC specification:+--+-- \"An integer is a 32-bit signed number. You can include a plus or+-- minus at the beginning of a string of numeric characters. Leading+-- zeros are collapsed. Whitespace is not permitted. Just numeric+-- characters preceeded by a plus or minus.\"+readInt :: Monad m => String -> Err m Int+readInt s = errorRead reads "Error parsing integer" s+++-- | From the XML-RPC specification:+--+-- \"0 (false) or 1 (true)\"+readBool :: Monad m => String -> Err m Bool+readBool s = errorRead readsBool "Error parsing boolean" s+ where readsBool "true" = [(True,"")]+ readsBool "false" = [(False,"")]+ readsBool "1" = [(True,"")]+ readsBool "0" = [(False,"")]+ readsBool _ = []++-- | From the XML-RPC specification:+--+-- \"Any characters are allowed in a string except \< and &, which are+-- encoded as < and &. A string can be used to encode binary data.\"+--+-- To work with implementations (such as some Python bindings for example) +-- which also escape \>, > is unescaped. This is non-standard, but+-- seems unlikely to cause problems.+readString :: Monad m => String -> Err m String+readString = return . replace "&" "&" . replace "<" "<"+ . replace ">" ">"+++-- | From the XML-RPC specification:+-- +-- There is no representation for infinity or negative infinity or \"not+-- a number\". At this time, only decimal point notation is allowed, a+-- plus or a minus, followed by any number of numeric characters,+-- followed by a period and any number of numeric+-- characters. Whitespace is not allowed. The range of allowable values+-- is implementation-dependent, is not specified.+--+-- FIXME: accepts more than decimal point notation+readDouble :: Monad m => String -> Err m Double+readDouble s = errorRead reads "Error parsing double" s++-- | From <http://groups.yahoo.com/group/xml-rpc/message/4733>:+--+-- \"Essentially \"dateTime.iso8601\" is a misnomer and the format of the+-- content of this element should not be assumed to comply with the+-- variants of the ISO8601 standard. Only assume YYYYMMDDTHH:mm:SS\"+-- FIXME: make more robust+readDateTime :: Monad m => String -> Err m CalendarTime+readDateTime (x:xs) | isSpace x = readDateTime xs+readDateTime (y1:y2:y3:y4:m1:m2:d1:d2:'T':h1:h2:':':mi1:mi2:':':s1:s2:xs) + | all isSpace xs =+ do+ y <- errorRead reads "Error parsing year" [y1,y2,y3,y4] + m' <- errorRead reads "Error parsing month" [m1,m2] + m <- errorToEnum ("Bad month number: " ++ show m') (m'-1)+ d <- errorRead reads "Error parsing day" [d1,d2]+ h <- errorRead reads "Error parsing hour" [h1,h2]+ mi <- errorRead reads "Error parsing minute" [mi1,mi2]+ s <- errorRead reads "Error parsing second" [s1,s2]+ return (mkUTCTime y m d h mi s)+readDateTime s = fail ("Error parsing dateTime '" ++ s ++ "'")++-- | Hack to avoid having to fill in all CalendarTime fields+mkUTCTime :: Int -- ^ Year+ -> Month -- ^ Month+ -> Int -- ^ Day+ -> Int -- ^ Hour+ -> Int -- ^ Minute+ -> Int -- ^ Second+ -> CalendarTime +mkUTCTime y m d h mi s = + toUTCTime $ toClockTime $ + CalendarTime { ctYear = y, ctMonth = m, ctDay = d, + ctHour = h, ctMin = mi, ctSec = s, + ctPicosec = 0, ctWDay = undefined, + ctYDay = undefined, ctTZName = undefined,+ ctTZ = 0, ctIsDST = undefined }+++-- FIXME: what if data contains non-base64 characters?+readBase64 :: Monad m => String -> Err m String+readBase64 = return . octetsToString . decode+ where+ -- FIXME: this probably only works right for latin-1 strings+ octetsToString :: [Word8] -> String+ octetsToString = map (toEnum . fromIntegral)+++fromXRParams :: Monad m => XR.Params -> Err m [Value]+fromXRParams (XR.Params xps) = mapM (\(XR.Param v) -> fromXRValue v) xps++fromXRMethodCall :: Monad m => XR.MethodCall -> Err m MethodCall+fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = + liftM (MethodCall name) (fromXRParams (fromMaybe (XR.Params []) params))++fromXRMethodResponse :: Monad m => XR.MethodResponse -> Err m MethodResponse+fromXRMethodResponse (XR.MethodResponseParams xps) = + liftM Return (fromXRParams xps >>= onlyOneResult)+fromXRMethodResponse (XR.MethodResponseFault (XR.Fault v)) =+ do+ struct <- fromXRValue v+ vcode <- structGetValue "faultCode" struct+ code <- fromValue vcode+ vstr <- structGetValue "faultString" struct+ str <- fromValue vstr+ return (Fault code str)++--+-- Parsing calls and reponses from XML+-- ++-- | Parses a method call from XML.+parseCall :: Monad m => String -> Err m MethodCall+parseCall c = + do+ mxc <- errorToErr (readXml c)+ xc <- maybeToM "Error parsing method call" mxc+ fromXRMethodCall xc++-- | Parses a method response from XML.+parseResponse :: Monad m => String -> Err m MethodResponse+parseResponse c = + do+ mxr <- errorToErr (readXml c)+ xr <- maybeToM "Error parsing method response" mxr+ fromXRMethodResponse xr++--+-- Rendering calls and reponses to XML+--++-- | Makes an XML-representation of a method call.+-- FIXME: pretty prints ugly XML+renderCall :: MethodCall -> String+renderCall = showXml . toXRMethodCall++-- | Makes an XML-representation of a method response.+-- FIXME: pretty prints ugly XML+renderResponse :: MethodResponse -> String+renderResponse = showXml . toXRMethodResponse
+ Network/XmlRpc/Introspect.hs view
@@ -0,0 +1,31 @@+module Network.XmlRpc.Introspect where++import Network.XmlRpc.Internals+import Network.XmlRpc.Client++type Signature = ([Type],Type)+type Help = String+type MethodInfo = (String,[Signature],Help)++-- Primitive introspection functions++listMethods :: String -> IO [String]+listMethods url = remote url "system.listMethods"++methodSignature :: String -> String -> IO [[String]]+methodSignature url = remote url "system.methodSignature"++methodHelp :: String -> String -> IO String+methodHelp url = remote url "system.methodHelp"+++signatures :: String -> String -> IO [Signature]+signatures url name = do+ sigs <- methodSignature url name+ return [ (map read as,read r) | (r:as) <- sigs ]++methodInfo :: String -> String -> IO MethodInfo+methodInfo url name = do+ sigs <- signatures url name+ help <- methodHelp url name+ return (name, sigs, help)
+ Network/XmlRpc/Server.hs view
@@ -0,0 +1,162 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XmlRpc.Server+-- 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 server functionality of XML-RPC.+-- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.+--+-- A simple CGI-based XML-RPC server application:+--+-- > import Network.XmlRpc.Server +-- >+-- > add :: Int -> Int -> IO Int+-- > add x y = return (x + y)+-- >+-- > main = cgiXmlRpcServer [("examples.add", fun add)]+-----------------------------------------------------------------------------++module Network.XmlRpc.Server + (+ XmlRpcMethod, ServerResult,+ fun,+ handleCall, methods, cgiXmlRpcServer,+ ) where++import Network.XmlRpc.Internals++import Data.Maybe+import Control.Monad.Error+import Control.Exception++serverName = "Haskell XmlRpcServer/0.1"++--+-- API+--++type ServerResult = Err IO MethodResponse++type Signature = ([Type], Type)++-- | The type of XML-RPC methods on the server.+type XmlRpcMethod = (MethodCall -> ServerResult, Signature)++showException :: Exception -> String+showException ex = fromMaybe (show ex) (userErrors ex)++handleIO :: IO a -> Err IO a+handleIO io = lift (try io) >>= either (fail . showException) return+++--+-- Converting Haskell functions to XML-RPC methods+--++-- | Turns any function +-- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => +-- t1 -> ... -> tn -> IO r@+-- into an 'XmlRpcMethod'+fun :: XmlRpcFun a => a -> XmlRpcMethod+fun f = (toFun f, sig f)++class XmlRpcFun a where+ toFun :: a -> MethodCall -> ServerResult+ sig :: a -> Signature++instance XmlRpcType a => XmlRpcFun (IO a) where+ toFun x (MethodCall _ []) = do+ v <- handleIO x+ return (Return (toValue v))+ toFun _ _ = fail "Too many arguments"+ sig (_::IO a) = ([], getType (undefined::a))++instance (XmlRpcType a, XmlRpcFun b) => XmlRpcFun (a -> b) where+ toFun f (MethodCall n (x:xs)) = do+ v <- fromValue x+ toFun (f v) (MethodCall n xs)+ toFun _ _ = fail "Too few arguments"+ sig (f::a->b) = let (as, r) = sig (undefined::b) + in (getType (undefined::a) : as, r)++-- FIXME: always returns error code 0+errorToResponse :: ServerResult -> IO MethodResponse+errorToResponse = handleError (return . Fault 0)+++-- | Reads a method call from a string, uses the supplied method+-- to generate a response and returns that response as a string+handleCall :: (MethodCall -> ServerResult) -> String -> IO String+handleCall f str = do+ resp <- errorToResponse (parseCall str >>= f)+ return (renderResponse resp)++-- | An XmlRpcMethod that looks up the method name in a table+-- and uses that method to handle the call.+methods :: [(String,XmlRpcMethod)] -> MethodCall -> ServerResult+methods t c@(MethodCall name _) = + do+ (method,_) <- maybeToM ("Unknown method: " ++ name) (lookup name t)+ method c+++-- | A server with introspection support+server :: [(String,XmlRpcMethod)] -> String -> IO String+server t = handleCall (methods (addIntrospection t))++++--+-- Introspection+--++addIntrospection :: [(String,XmlRpcMethod)] -> [(String,XmlRpcMethod)]+addIntrospection t = t' + where t' = ("system.listMethods", fun (listMethods t')) : + ("system.methodSignature", fun (methodSignature t')) :+ ("system.methodHelp", fun (methodHelp t')) : t++listMethods :: [(String,XmlRpcMethod)] -> IO [String]+listMethods t = return (fst (unzip t))++methodSignature :: [(String,XmlRpcMethod)] -> String -> IO [[String]]+methodSignature t name = + do+ (_,(as,r)) <- maybeToM ("Unknown method: " ++ name) (lookup name t)+ return [map show (r:as)]++methodHelp :: [(String,XmlRpcMethod)] -> String -> IO String+methodHelp t name =+ do+ method <- maybeToM ("Unknown method: " ++ name) (lookup name t)+ return (help method)++-- FIXME: implement+help :: XmlRpcMethod -> String+help m = ""+++--+-- CGI server+--++-- | A CGI-based XML-RPC server. Reads a request from standard input+-- and writes some HTTP headers (Content-Type and Content-Length),+-- followed by the response to standard output. Supports+-- introspection.+cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO ()+cgiXmlRpcServer ms = + do+ input <- getContents+ output <- server ms input+ putStr ("Server: " ++ serverName ++ crlf)+ putStr ("Content-Type: text/xml" ++ crlf)+ putStr ("Content-Length: " ++ show (length output) ++ crlf)+ putStr crlf+ putStr output+ where crlf = "\r\n"
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ haxr.cabal view
@@ -0,0 +1,23 @@+Name: haxr+Version: 3000.0.0+Copyright: Bjorn Bringert, 2003-2006+Build-depends: base, mtl, network, HaXml >= 1.13 && < 1.14, HTTP >= 1.0+License: BSD4+License-file: LICENSE+Author: Bjorn Bringert <bjorn@bringert.net>+Maintainer: Bjorn Bringert <bjorn@bringert.net>+Homepage: http://www.haskell.org/haxr/+Synopsis: XML-RPC client and server library.+Description:+ HaXR is a library for writing XML-RPC + client and server applications in Haskell.+Exposed-Modules:+ Network.XmlRpc.Client,+ Network.XmlRpc.Server,+ Network.XmlRpc.Internals,+ Network.XmlRpc.Introspect+Other-Modules:+ Network.XmlRpc.Base64,+ Network.XmlRpc.DTD_XMLRPC+Extensions: OverlappingInstances, TypeSynonymInstances+GHC-options: -O2