diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/XmlRpc/Base64.hs b/Network/XmlRpc/Base64.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Base64.hs @@ -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 +-- and . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Client.hs @@ -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 . +-- +-- 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 diff --git a/Network/XmlRpc/DTD_XMLRPC.hs b/Network/XmlRpc/DTD_XMLRPC.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/DTD_XMLRPC.hs @@ -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 "" "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 "" "member" ca)) + (definite fromElem "" "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 "" "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 "" "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 "" "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-} diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Internals.hs @@ -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 . +-- +----------------------------------------------------------------------------- + +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 +-- , which can contain a single which contains a +-- single which contains a single ." +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 : +-- +-- \"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 diff --git a/Network/XmlRpc/Introspect.hs b/Network/XmlRpc/Introspect.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Introspect.hs @@ -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) diff --git a/Network/XmlRpc/Server.hs b/Network/XmlRpc/Server.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Server.hs @@ -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 . +-- +-- 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" diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/haxr.cabal b/haxr.cabal new file mode 100644 --- /dev/null +++ b/haxr.cabal @@ -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 +Maintainer: Bjorn Bringert +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