haxr 3000.2.1 → 3000.11.6.1
raw patch · 24 files changed
Files
- CHANGES +173/−0
- Network/XmlRpc/Base64.hs +6/−3
- Network/XmlRpc/Client.hs +144/−86
- Network/XmlRpc/DTD_XMLRPC.hs +304/−294
- Network/XmlRpc/Internals.hs +285/−215
- Network/XmlRpc/Introspect.hs +7/−7
- Network/XmlRpc/Pretty.hs +352/−0
- Network/XmlRpc/Server.hs +38/−32
- Network/XmlRpc/THDeriveXmlRpcType.hs +106/−0
- examples/Makefile +20/−0
- examples/Person.hs +22/−0
- examples/PersonTH.hs +14/−0
- examples/make-stubs.hs +71/−0
- examples/parse_response.hs +9/−0
- examples/person_client.hs +13/−0
- examples/person_server.hs +13/−0
- examples/raw_call.hs +77/−0
- examples/simple_client.hs +14/−0
- examples/simple_server.hs +8/−0
- examples/test_client.hs +38/−0
- examples/test_server.hs +18/−0
- examples/time-xmlrpc-com.hs +11/−0
- examples/validate.hs +71/−0
- haxr.cabal +57/−13
+ CHANGES view
@@ -0,0 +1,173 @@+* 3000.11.6.1 (4 April 2026)++ - Update and/or remove some dependency upper bounds (`base`, `base-compat`, `mtl`, `network`, `HaXml`, `blaze-builder`)+ - Support GHC 9.14++* 3000.11.6 (10 November 2025)++ - Add 'Accept: application/xml' header to requests. Thanks to Jens+ Petersen for the patch.++* 3000.11.5.1 (29 July 2024)++ - Support GHC 9.10 and fix warnings++ - r1 (4 June 2025): support GHC 9.12++* 3000.11.5 (17 March 2023)++ - Updates for `mtl-2.3`.+ - Add an upper bound on `mtl` to prevent future breakage.++ - r1 (25 March 2023): support GHC 9.6, `base-compat-0.13`+ - r2 (23 Oct 2023): support GHC 9.8+ - r3 (16 Apr 2024): allow `network-3.2`++* 3000.11.4.1 (9 July 2020)++ - Support GHC-8.10++ - r1 (29 Sep 2021): support GHC 9.0+ - r2 (21 March 2022): support GHC 9.2+ - r3 (9 Sep 2022): support GHC 9.4++* 3000.11.4 (24 January 2020)++ - Add support for <nil/> corresponding to unit () in Haskell++* 3000.11.3.1 (17 December 2019)++ - Updates for GHC 8.8, network-3.1+ - Use MonadFail instead of Monad for 'fail' method++* 3000.11.3 (19 January 2019)++ - Updates for GHC 8.6++* 3000.11.2 (9 August 2016)++ - Add XmlRpcType instance for Text++* 3000.11.1.6 (30 May 2016)++ - bug fix: default port is now 80 or 443 based on protocol++* 3000.11.1.5 (13 May 2016)++ - bug fix in parsing username & password from URI++* 3000.11.1.4 (18 March 2016)++ - build with template-haskell 2.11 / GHC 8.0.1++* 3000.11.1.3 (15 January 2016)++ - allow base-compat-0.9++* 3000.11.1.2 (20 September 2015)++ - `>` is now escaped as `>` when sending requests. Without this+ some XML-RPC servers will break when receiving an embedded CDATA section+ (e.g. Atlassian Confluence).++* 3000.11.1.1 (21 July 2015)++ - Bug fix: don't crash with empty URI port++* 3000.11.1 (10 July 2015)++ - Support both HTTP and HTTPS automatically, depending on URL.+ - Bug fixes:+ - read port properly+ - set request path properly+ - set content-length header++* 3000.11 (1 June 2015)++ - Switch from the HTTP package to http-streams, and add support for+ HTTPS. The types of a few of the internal methods may have+ changed, but for the most part code depending on haxr should+ continue to work unchanged.++* 3000.10.4.2 (23 February 2015)++ - add mtl-compat dependency++* 3000.10.4.1 (22 February 2015)++ - Fix build on GHC 7.4++* 3000.10.4 (22 February 2015)++ - Build on GHC 7.10+ - allow HaXml 1.25+ - allow blaze-builder-0.4++* 3000.10.3.1 (5 September 2014)++ - Update .cabal file to deal with network-uri split.++* 3000.10.3 (18 June 2014)++ - Parse unwrapped text as a String value in accordance with the+ XML-RPC spec.++* 3000.10.2 (30 January 2014)++ - Adds support for i8 (64-bit integer) types: see new I8 type in+ Network.XmlRpc.DTD_XMLRPC. Thanks to Jorge Peña for the patch.++* 3000.10.1.1 (10 October 2013)++ - fix build under GHC 7.4++* 3000.10.1 (10 October 2013)++ - Export XML conversion functions from Network.XmlRpc.Internals++* 3000.10 (10 October 2013)++ - Add an "unwrapped" value type that does not wrap the inner value+ string with an XML element. This should only affect users who+ depend on Network.XmlRpc.Internals.++* 3000.9.3 (18 May 2013)++ - Critical bug fix --- do not use 3000.9.2, it is extremely broken+ (hangs forever when trying to send a request).++* 3000.9.2.1 (15 May 2013)++ - Allow HaXml-1.24++* 3000.9.2 (14 May 2013)++ - Export new functions remoteWithHeaders and callWithHeaders, which+ are variants of remote and call that allow the user to specify+ extra custom headers. Thanks to Ben Sinclair for the patch.++* 3000.9.1 (4 May 2013)++ - Expose Network.XmlRpc.DTD_XMLRPC from the library++ The point is to allow converting to XML using functions from++ http://hackage.haskell.org/packages/archive/HaXml/1.23.3/doc/html/Text-XML-HaXml-XmlContent.html++ which allows for custom serialization of the XML to deal with+ endpoints that don't parse XML correctly.++* 3000.9.0.1 (7 July 2012)++ - Make everything in examples/ directory compile again++* 3000.9 (7 July 2012)++ - Switch from dataenc to base64-bytestring for base64 encoding,+ resulting in dramatically improved efficiency++ - Change the argument type of ValueBase64 constructor from String to+ ByteString++ - bump HaXml dependency upper bound to allow HaXml 1.23.*+
Network/XmlRpc/Base64.hs view
@@ -3,8 +3,11 @@ decode ) where -import qualified Codec.Binary.Base64 as B64-import Data.Maybe+import Data.ByteString+import qualified Data.ByteString.Base64 as B64 +encode :: ByteString -> ByteString encode = B64.encode-decode = fromJust . B64.decode++decode :: ByteString -> ByteString+decode = B64.decodeLenient
Network/XmlRpc/Client.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XmlRpc.Client -- Copyright : (c) Bjorn Bringert 2003 -- License : BSD-style--- +-- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (requires extensions and non-portable libraries)@@ -19,7 +21,7 @@ -- > -- > add :: String -> Int -> Int -> IO Int -- > add url = remote url "examples.add"--- > +-- > -- > main = do -- > let x = 4 -- > y = 7@@ -30,70 +32,110 @@ module Network.XmlRpc.Client (- remote,- call,+ remote, remoteWithHeaders,+ call, callWithHeaders, Remote ) where -import qualified Network.XmlRpc.Base64 as Base64-import Network.XmlRpc.Internals+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 Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail as Fail+import Data.Functor ((<$>))+import Data.Int+import Data.List (uncons)+import Data.Maybe+import Network.URI+import Text.Read.Compat (readMaybe) -import Network.HTTP-import Network.Stream+import Network.Http.Client (Method (..), Request,+ baselineContextSSL, buildRequest,+ closeConnection, getStatusCode,+ getStatusMessage, http,+ inputStreamBody, openConnection,+ openConnectionSSL, receiveResponse,+ sendRequest, setAccept,+ setAuthorizationBasic,+ setContentLength, setContentType,+ setHeader)+import OpenSSL+import qualified System.IO.Streams as Streams +import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, fromChunks,+ length, unpack)+import qualified Data.ByteString.Lazy.UTF8 as U -- | Gets the return value from a method response. -- Throws an exception if the response was a fault.-handleResponse :: Monad m => MethodResponse -> m Value-handleResponse (Return v) = return v+handleResponse :: MonadFail m => MethodResponse -> m Value+handleResponse (Return v) = return v handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ str) +type HeadersAList = [(BS.ByteString, BS.ByteString)]+ -- | Sends a method call to a server and returns the response. -- Throws an exception if the response was an error.-doCall :: String -> MethodCall -> Err IO MethodResponse-doCall url mc = - do +doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse+doCall url headers mc =+ do let req = renderCall mc- --FIXME: remove- --putStrLn req- resp <- ioErrorToErr $ post url req- --FIXME: remove- --putStrLn resp- parseResponse resp+ resp <- ioErrorToErr $ post url headers req+ parseResponse (BSL.unpack resp) -- | Low-level method calling function. Use this function if--- you need to do custom conversions between XML-RPC types and +-- 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 url method args = doCall url [] (MethodCall method args) >>= handleResponse +-- | Low-level method calling function. Use this function if+-- you need to do custom conversions between XML-RPC types and+-- Haskell types. Takes a list of extra headers to add to the+-- HTTP request.+-- Throws an exception if the response was a fault.+callWithHeaders :: String -- ^ URL for the XML-RPC server.+ -> String -- ^ Method name.+ -> HeadersAList -- ^ Extra headers to add to HTTP request.+ -> [Value] -- ^ The arguments.+ -> Err IO Value -- ^ The result+callWithHeaders url method headers args =+ doCall url headers (MethodCall method args) >>= handleResponse + -- | Call a remote method.-remote :: Remote a => - String -- ^ Server URL. May contain username and password on- -- the format username:password\@ before the hostname.+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) => + -> a -- ^ Any function+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m) +-- | Call a remote method. Takes a list of extra headers to add to the HTTP+-- request.+remoteWithHeaders :: Remote a =>+ String -- ^ Server URL. May contain username and password on+ -- the format username:password\@ before the hostname.+ -> String -- ^ Remote method name.+ -> HeadersAList -- ^ Extra headers to add to HTTP request.+ -> a -- ^ Any function+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>+ -- t1 -> ... -> tn -> IO r@+remoteWithHeaders u m headers =+ remote_ (\e -> "Error calling " ++ m ++ ": " ++ e)+ (callWithHeaders u m headers)+ class Remote a where remote_ :: (String -> String) -- ^ Will be applied to all error- -- messages.- -> ([Value] -> Err IO Value) - -> a+ -- messages.+ -> ([Value] -> Err IO Value)+ -> a instance XmlRpcType a => Remote (IO a) where remote_ h f = handleError (fail . h) $ f [] >>= fromValue@@ -107,72 +149,88 @@ -- HTTP functions -- -userAgent :: String+userAgent :: BS.ByteString 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++post :: String -> HeadersAList -> BSL.ByteString -> IO U.ByteString+post url headers 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+ let a = uriAuthority uri+ auth <- maybeFail ("Bad URI authority: '" ++ show (fmap showAuth a) ++ "'") a+ post_ uri auth headers content+ where showAuth (URIAuth u r p) = "URIAuth "++u++" "++r++" "++p -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail?-post_ :: URI -> 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+post_ :: URI -> URIAuth -> HeadersAList -> BSL.ByteString -> IO U.ByteString+post_ uri auth headers content = withOpenSSL $ do+ let hostname = BS.pack (uriRegName auth)+ port base = fromMaybe base (readMaybe $ drop 1 $ uriPort auth) + c <- case init $ uriScheme uri of+ "http" ->+ openConnection hostname (port 80)+ "https" -> do+ ctx <- baselineContextSSL+ openConnectionSSL ctx hostname (port 443)+ x -> fail ("Unknown scheme: '" ++ x ++ "'!")++ req <- request uri auth headers (BSL.length content)+ body <- inputStreamBody <$> Streams.fromLazyByteString content++ _ <- sendRequest c req body++ s <- receiveResponse c $ \resp i -> do+ case getStatusCode resp of+ 200 -> readLazyByteString i+ _ -> fail (show (getStatusCode resp) ++ " " ++ BS.unpack (getStatusMessage resp))++ closeConnection c++ return s++readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString+readLazyByteString i = BSL.fromChunks <$> go+ where+ go :: IO [BS.ByteString]+ go = do+ res <- Streams.read i+ case res of+ Nothing -> return []+ Just bs -> (bs:) <$> go+ -- | Create an XML-RPC compliant HTTP request.-request :: URI -> URIAuthority -> String -> Request_String-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))+request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request+request uri auth usrHeaders len = buildRequest $ do+ http POST (BS.pack $ uriPath uri)+ setContentType "text/xml"+ setContentLength len+ setAccept "application/xml" --- | 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 = Base64.encode . stringToOctets- -- FIXME: this probably only works right for latin-1 strings- stringToOctets :: String -> [Word8]- stringToOctets = map (fromIntegral . fromEnum)+ case parseUserInfo auth of+ (Just user, Just pass) -> setAuthorizationBasic (BS.pack user) (BS.pack pass)+ _ -> return () + mapM_ (uncurry setHeader) usrHeaders++ setHeader "User-Agent" userAgent++ where+ parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info+ in ( if null u then Nothing else Just u+ , (dropAtEnd . snd) <$> uncons pw )+ -- -- Utility functions -- -maybeFail :: Monad m => String -> Maybe a -> m a-maybeFail msg = maybe (fail msg) return+maybeFail :: MonadFail m => String -> Maybe a -> m a+maybeFail msg = maybe (Fail.fail msg) return++dropAtEnd :: String -> String+dropAtEnd l = take (length l - 1) l
Network/XmlRpc/DTD_XMLRPC.hs view
@@ -1,294 +1,304 @@-module Network.XmlRpc.DTD_XMLRPC where - -import Text.XML.HaXml.Xml2Haskell -import Text.XML.HaXml.OneOfN -import Data.Char (isSpace) - - -{-Type decls-} - -newtype I4 = I4 String deriving (Eq,Show) -newtype AInt = AInt String deriving (Eq,Show) -newtype Boolean = Boolean String deriving (Eq,Show) -newtype AString = AString String deriving (Eq,Show) -newtype ADouble = ADouble String deriving (Eq,Show) -newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show) -newtype Base64 = Base64 String deriving (Eq,Show) -newtype Data = Data [Value] deriving (Eq,Show) -newtype Array = Array Data deriving (Eq,Show) -newtype Name = Name String deriving (Eq,Show) -data Member = Member Name Value - deriving (Eq,Show) -newtype Struct = Struct [Member] deriving (Eq,Show) -newtype Value = Value [Value_] deriving (Eq,Show) -data Value_ = Value_Str String - | Value_I4 I4 - | Value_AInt AInt - | Value_Boolean Boolean - | Value_AString AString - | Value_DateTime_iso8601 DateTime_iso8601 - | Value_ADouble ADouble - | Value_Base64 Base64 - | Value_Struct Struct - | Value_Array Array - deriving (Eq,Show) -newtype Param = Param Value deriving (Eq,Show) -newtype Params = Params [Param] deriving (Eq,Show) -newtype MethodName = MethodName String deriving (Eq,Show) -data MethodCall = MethodCall MethodName (Maybe Params) - deriving (Eq,Show) -newtype Fault = Fault Value deriving (Eq,Show) -data MethodResponse = MethodResponseParams Params - | MethodResponseFault Fault - deriving (Eq,Show) - - -{-Instance decls-} - -instance XmlContent I4 where - fromElem (CElem (Elem "i4" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (I4 a) = - [CElem (Elem "i4" [] (toText a))] -instance XmlContent AInt where - fromElem (CElem (Elem "int" [] c0):rest) = - (\(a,ca)-> - (Just (AInt a), rest)) - (definite fromText "text" "int" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (AInt a) = - [CElem (Elem "int" [] (toText a))] -instance XmlContent Boolean where - fromElem (CElem (Elem "boolean" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (Boolean a) = - [CElem (Elem "boolean" [] (toText a))] -instance XmlContent AString where - fromElem (CElem (Elem "string" [] c0):rest) = - (\(a,ca)-> - (Just (AString a), rest)) - (definite fromText "text" "string" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (AString a) = - [CElem (Elem "string" [] (toText a))] -instance XmlContent ADouble where - fromElem (CElem (Elem "double" [] c0):rest) = - (\(a,ca)-> - (Just (ADouble a), rest)) - (definite fromText "text" "double" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (ADouble a) = - [CElem (Elem "double" [] (toText a))] -instance XmlContent DateTime_iso8601 where - fromElem (CElem (Elem "dateTime.iso8601" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (DateTime_iso8601 a) = - [CElem (Elem "dateTime.iso8601" [] (toText a))] -instance XmlContent Base64 where - fromElem (CElem (Elem "base64" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (Base64 a) = - [CElem (Elem "base64" [] (toText a))] -instance XmlContent Data where - fromElem (CElem (Elem "data" [] c0):rest) = - (\(a,ca)-> - (Just (Data a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Data a) = - [CElem (Elem "data" [] (concatMap toElem a))] -instance XmlContent Array where - fromElem (CElem (Elem "array" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (Array a) = - [CElem (Elem "array" [] (toElem a))] -instance XmlContent Name where - fromElem (CElem (Elem "name" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (Name a) = - [CElem (Elem "name" [] (toText a))] -instance XmlContent Member where - fromElem (CElem (Elem "member" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (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 = (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)-> - (Just (Struct a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Struct a) = - [CElem (Elem "struct" [] (concatMap toElem a))] -instance XmlContent Value where - fromElem (CElem (Elem "value" [] c0):rest) = - (\(a,ca)-> - (Just (Value a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Value a) = - [CElem (Elem "value" [] (concatMap toElem a))] -instance XmlContent Value_ where - fromElem c0 = - case (fromText c0) of - (Just a,rest) -> (Just (Value_Str a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_I4 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_AInt a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Boolean a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_AString a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_DateTime_iso8601 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_ADouble a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Base64 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Struct a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Array a), rest) - (_,_) -> - (Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Value_Str a) = toText a - toElem (Value_I4 a) = toElem a - toElem (Value_AInt a) = toElem a - toElem (Value_Boolean a) = toElem a - toElem (Value_AString a) = toElem a - toElem (Value_DateTime_iso8601 a) = toElem a - toElem (Value_ADouble 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)-> - (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 = (Nothing, rest) - toElem (Param a) = - [CElem (Elem "param" [] (toElem a))] -instance XmlContent Params where - fromElem (CElem (Elem "params" [] c0):rest) = - (\(a,ca)-> - (Just (Params a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Params a) = - [CElem (Elem "params" [] (concatMap toElem a))] -instance XmlContent MethodName where - fromElem (CElem (Elem "methodName" [] c0):rest) = - (\(a,ca)-> - (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 = (Nothing, rest) - toElem (MethodName a) = - [CElem (Elem "methodName" [] (toText a))] -instance XmlContent MethodCall where - fromElem (CElem (Elem "methodCall" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (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 = (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)-> - (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 = (Nothing, rest) - toElem (Fault a) = - [CElem (Elem "fault" [] (toElem a))] -instance XmlContent MethodResponse where - fromElem (CElem (Elem "methodResponse" [] c0):rest) = - case (fromElem c0) of - (Just a,_) -> (Just (MethodResponseParams a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,_) -> (Just (MethodResponseFault a), rest) - (_,_) -> - (Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (MethodResponseParams a) = [CElem (Elem "methodResponse" [] (toElem a) )] - toElem (MethodResponseFault a) = [CElem (Elem "methodResponse" [] (toElem a) )] - - -{-Done-} +module Network.XmlRpc.DTD_XMLRPC where++import Text.XML.HaXml.OneOfN+import Text.XML.HaXml.Types (QName (..))+import Text.XML.HaXml.XmlContent+++{-Type decls-}++newtype I4 = I4 String deriving (Eq,Show)+newtype I8 = I8 String deriving (Eq,Show)+newtype AInt = AInt String deriving (Eq,Show)+newtype Boolean = Boolean String deriving (Eq,Show)+newtype AString = AString String deriving (Eq,Show)+newtype ADouble = ADouble String deriving (Eq,Show)+newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show)+newtype Base64 = Base64 String deriving (Eq,Show)+newtype Data = Data [Value] deriving (Eq,Show)+newtype Array = Array Data deriving (Eq,Show)+newtype Name = Name String deriving (Eq,Show)+data Member = Member Name Value+ deriving (Eq,Show)+newtype Struct = Struct [Member] deriving (Eq,Show)+newtype Nil = Nil () deriving (Eq,Show)+newtype Value = Value [Value_] deriving (Eq,Show)+data Value_ = Value_Str String+ | Value_I4 I4+ | Value_I8 I8+ | Value_AInt AInt+ | Value_Boolean Boolean+ | Value_AString AString+ | Value_DateTime_iso8601 DateTime_iso8601+ | Value_ADouble ADouble+ | Value_Base64 Base64+ | Value_Struct Struct+ | Value_Array Array+ | Value_Nil Nil+ deriving (Eq,Show)+newtype Param = Param Value deriving (Eq,Show)+newtype Params = Params [Param] deriving (Eq,Show)+newtype MethodName = MethodName String deriving (Eq,Show)+data MethodCall = MethodCall MethodName (Maybe Params)+ deriving (Eq,Show)+newtype Fault = Fault Value deriving (Eq,Show)+data MethodResponse = MethodResponseParams Params+ | MethodResponseFault Fault+ deriving (Eq,Show)+++{-Instance decls-}++instance HTypeable I4 where+ toHType x = Defined "i4" [] []+instance XmlContent I4 where+ toContents (I4 a) =+ [CElem (Elem (N "i4") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["i4"]+ ; interior e $ return (I4) `apply` (text `onFail` return "")+ } `adjustErr` ("in <i4>, "++)++instance HTypeable I8 where+ toHType x = Defined "i8" [] []+instance XmlContent I8 where+ toContents (I8 a) =+ [CElem (Elem (N "i8") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["i8"]+ ; interior e $ return (I8) `apply` (text `onFail` return "")+ } `adjustErr` ("in <i8>, "++)++instance HTypeable AInt where+ toHType x = Defined "int" [] []+instance XmlContent AInt where+ toContents (AInt a) =+ [CElem (Elem (N "int") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["int"]+ ; interior e $ return (AInt) `apply` (text `onFail` return "")+ } `adjustErr` ("in <int>, "++)++instance HTypeable Boolean where+ toHType x = Defined "boolean" [] []+instance XmlContent Boolean where+ toContents (Boolean a) =+ [CElem (Elem (N "boolean") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["boolean"]+ ; interior e $ return (Boolean) `apply` (text `onFail` return "")+ } `adjustErr` ("in <boolean>, "++)++instance HTypeable AString where+ toHType x = Defined "string" [] []+instance XmlContent AString where+ toContents (AString a) =+ [CElem (Elem (N "string") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["string"]+ ; interior e $ return (AString) `apply` (text `onFail` return "")+ } `adjustErr` ("in <string>, "++)++instance HTypeable ADouble where+ toHType x = Defined "double" [] []+instance XmlContent ADouble where+ toContents (ADouble a) =+ [CElem (Elem (N "double") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["double"]+ ; interior e $ return (ADouble) `apply` (text `onFail` return "")+ } `adjustErr` ("in <double>, "++)++instance HTypeable DateTime_iso8601 where+ toHType x = Defined "dateTime.iso8601" [] []+instance XmlContent DateTime_iso8601 where+ toContents (DateTime_iso8601 a) =+ [CElem (Elem (N "dateTime.iso8601") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["dateTime.iso8601"]+ ; interior e $ return (DateTime_iso8601)+ `apply` (text `onFail` return "")+ } `adjustErr` ("in <dateTime.iso8601>, "++)++instance HTypeable Nil where+ toHType x = Defined "nil" [] []+instance XmlContent Nil where+ toContents (Nil a) =+ [CElem (Elem (N "nil") [] []) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["nil"]+ ; interior e $ return (Nil) `apply` (return ())+ } `adjustErr` ("in <nil/>, "++)++instance HTypeable Base64 where+ toHType x = Defined "base64" [] []+instance XmlContent Base64 where+ toContents (Base64 a) =+ [CElem (Elem (N "base64") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["base64"]+ ; interior e $ return (Base64) `apply` (text `onFail` return "")+ } `adjustErr` ("in <base64>, "++)++instance HTypeable Data where+ toHType x = Defined "data" [] []+instance XmlContent Data where+ toContents (Data a) =+ [CElem (Elem (N "data") [] (concatMap toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["data"]+ ; interior e $ return (Data) `apply` many parseContents+ } `adjustErr` ("in <data>, "++)++instance HTypeable Array where+ toHType x = Defined "array" [] []+instance XmlContent Array where+ toContents (Array a) =+ [CElem (Elem (N "array") [] (toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["array"]+ ; interior e $ return (Array) `apply` parseContents+ } `adjustErr` ("in <array>, "++)++instance HTypeable Name where+ toHType x = Defined "name" [] []+instance XmlContent Name where+ toContents (Name a) =+ [CElem (Elem (N "name") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["name"]+ ; interior e $ return (Name) `apply` (text `onFail` return "")+ } `adjustErr` ("in <name>, "++)++instance HTypeable Member where+ toHType x = Defined "member" [] []+instance XmlContent Member where+ toContents (Member a b) =+ [CElem (Elem (N "member") [] (toContents a ++ toContents b)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["member"]+ ; interior e $ return (Member) `apply` parseContents+ `apply` parseContents+ } `adjustErr` ("in <member>, "++)++instance HTypeable Struct where+ toHType x = Defined "struct" [] []+instance XmlContent Struct where+ toContents (Struct a) =+ [CElem (Elem (N "struct") [] (concatMap toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["struct"]+ ; interior e $ return (Struct) `apply` many parseContents+ } `adjustErr` ("in <struct>, "++)++instance HTypeable Value where+ toHType x = Defined "value" [] []+instance XmlContent Value where+ toContents (Value a) =+ [CElem (Elem (N "value") [] (concatMap toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["value"]+ ; interior e $ return (Value) `apply` many parseContents+ } `adjustErr` ("in <value>, "++)++instance HTypeable Value_ where+ toHType x = Defined "value" [] []+instance XmlContent Value_ where+ toContents (Value_Str a) = toText a+ toContents (Value_I4 a) = toContents a+ toContents (Value_I8 a) = toContents a+ toContents (Value_AInt a) = toContents a+ toContents (Value_Boolean a) = toContents a+ toContents (Value_AString a) = toContents a+ toContents (Value_DateTime_iso8601 a) = toContents a+ toContents (Value_ADouble a) = toContents a+ toContents (Value_Base64 a) = toContents a+ toContents (Value_Struct a) = toContents a+ toContents (Value_Array a) = toContents a+ toContents (Value_Nil a) = toContents a+ parseContents = oneOf+ [ return (Value_Str) `apply` text+ , return (Value_I4) `apply` parseContents+ , return (Value_I8) `apply` parseContents+ , return (Value_AInt) `apply` parseContents+ , return (Value_Boolean) `apply` parseContents+ , return (Value_AString) `apply` parseContents+ , return (Value_DateTime_iso8601) `apply` parseContents+ , return (Value_ADouble) `apply` parseContents+ , return (Value_Base64) `apply` parseContents+ , return (Value_Struct) `apply` parseContents+ , return (Value_Array) `apply` parseContents+ , return (Value_Nil) `apply` parseContents+ ] `adjustErr` ("in <value>, "++)++instance HTypeable Param where+ toHType x = Defined "param" [] []+instance XmlContent Param where+ toContents (Param a) =+ [CElem (Elem (N "param") [] (toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["param"]+ ; interior e $ return (Param) `apply` parseContents+ } `adjustErr` ("in <param>, "++)++instance HTypeable Params where+ toHType x = Defined "params" [] []+instance XmlContent Params where+ toContents (Params a) =+ [CElem (Elem (N "params") [] (concatMap toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["params"]+ ; interior e $ return (Params) `apply` many parseContents+ } `adjustErr` ("in <params>, "++)++instance HTypeable MethodName where+ toHType x = Defined "methodName" [] []+instance XmlContent MethodName where+ toContents (MethodName a) =+ [CElem (Elem (N "methodName") [] (toText a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["methodName"]+ ; interior e $ return (MethodName)+ `apply` (text `onFail` return "")+ } `adjustErr` ("in <methodName>, "++)++instance HTypeable MethodCall where+ toHType x = Defined "methodCall" [] []+instance XmlContent MethodCall where+ toContents (MethodCall a b) =+ [CElem (Elem (N "methodCall") [] (toContents a +++ maybe [] toContents b)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["methodCall"]+ ; interior e $ return (MethodCall) `apply` parseContents+ `apply` optional parseContents+ } `adjustErr` ("in <methodCall>, "++)++instance HTypeable Fault where+ toHType x = Defined "fault" [] []+instance XmlContent Fault where+ toContents (Fault a) =+ [CElem (Elem (N "fault") [] (toContents a)) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["fault"]+ ; interior e $ return (Fault) `apply` parseContents+ } `adjustErr` ("in <fault>, "++)++instance HTypeable MethodResponse where+ toHType x = Defined "methodResponse" [] []+instance XmlContent MethodResponse where+ toContents (MethodResponseParams a) =+ [CElem (Elem (N "methodResponse") [] (toContents a) ) ()]+ toContents (MethodResponseFault a) =+ [CElem (Elem (N "methodResponse") [] (toContents a) ) ()]+ parseContents = do+ { e@(Elem _ [] _) <- element ["methodResponse"]+ ; interior e $ oneOf+ [ return (MethodResponseParams) `apply` parseContents+ , return (MethodResponseFault) `apply` parseContents+ ] `adjustErr` ("in <methodResponse>, "++)+ }++++{-Done-}
Network/XmlRpc/Internals.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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. +-- This module contains the core functionality of the XML-RPC library. -- Most applications should not need to use this module. Client -- applications should use "Network.XmlRpc.Client" and server applications should -- use "Network.XmlRpc.Server".@@ -17,43 +18,66 @@ -- ----------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_ {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif+ module Network.XmlRpc.Internals ( -- * Method calls and repsonses MethodCall(..), MethodResponse(..), -- * XML-RPC types Value(..), Type(..), XmlRpcType(..),--- * Converting from XML +-- * Converting from XML parseResponse, parseCall, getField, getFieldMaybe,--- * Converting to XML +-- * Converting to XML renderCall, renderResponse,+-- * Converting to and from DTD types+toXRValue, fromXRValue,+toXRMethodCall, fromXRMethodCall,+toXRMethodResponse, fromXRMethodResponse,+toXRParams, fromXRParams,+toXRMember, fromXRMember, -- * Error monad Err, maybeToM, handleError, ioErrorToErr ) where -import Prelude hiding (showString, catch)-import Control.Monad-import Data.Maybe-import Data.List-import Data.Time.Calendar-import Data.Time.Calendar.WeekDate (toWeekDate)-import Data.Time.Calendar.OrdinalDate (toOrdinalDate)-import Data.Time.LocalTime-import Data.Time.Format-import Data.Word (Word8)-import Numeric (showFFloat)-import Data.Char-import System.Time (CalendarTime(..))-import System.Locale-import Control.Exception-import Control.Monad.Error-import Control.Monad.Identity-import System.IO.Unsafe (unsafePerformIO)+import Control.Exception+import Control.Monad+import Control.Monad.Except (ExceptT, MonadError(..), runExceptT)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Maybe+import Data.Time.Calendar+import Data.Time.Calendar.OrdinalDate (toOrdinalDate)+import Data.Time.Calendar.WeekDate (toWeekDate)+import Data.Time.Format+import Data.Time.LocalTime+import Numeric (showFFloat)+import Prelude hiding (showString, catch)+import System.IO.Unsafe (unsafePerformIO)+import System.Time (CalendarTime(..)) -import Text.XML.HaXml.Xml2Haskell---import Text.XML.HaXml.XmlContent+#if ! MIN_VERSION_time(1,5,0)+import System.Locale (defaultTimeLocale)+#endif +import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack)+import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, pack) import qualified Network.XmlRpc.Base64 as Base64 import qualified Network.XmlRpc.DTD_XMLRPC as XR+import Network.XmlRpc.Pretty+import Text.XML.HaXml.XmlContent -- -- General utilities@@ -61,11 +85,11 @@ -- | 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 :: 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')@@ -73,103 +97,96 @@ | 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 :: MonadFail 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.fail err maybeToM _ (Just x) = return x -- | Convert a 'Maybe' value to a value in any monad-eitherToM :: Monad m+eitherToM :: MonadFail m => String -- ^ Error message to fail with for 'Nothing'- -> Either String a -- ^ The 'Maybe' value.- -> m a -- ^ The resulting value in the monad.-eitherToM err (Left s) = fail (err ++ ": " ++ s)+ -> Either String a -- ^ The 'Maybe' value.+ -> m a -- ^ The resulting value in the monad.+eitherToM err (Left s) = Fail.fail (err ++ ": " ++ s) eitherToM _ (Right x) = return x -- | The format for \"dateTime.iso8601\"+xmlRpcDateFormat :: String xmlRpcDateFormat = "%Y%m%dT%H:%M:%S" -- -- Error monad stuff -- -type Err m a = ErrorT String m a+type Err m a = ExceptT 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)+errorToErr :: (Show e, MonadError e m) => a -> Err m a+errorToErr x = unsafePerformIO (liftM return (evaluate x) `catch` handleErr)+ where handleErr :: Monad m => SomeException -> IO (Err m a)+ handleErr = return . throwError . show -- | Catch IO errors in the error monad. ioErrorToErr :: IO a -> Err IO a-ioErrorToErr = ErrorT . liftM (either (Left . show) Right) . tryJust ioErrors-+ioErrorToErr x = (liftIO x >>= return) `catchError` \e -> throwError (show e) -- | 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+handleError :: MonadFail m => (String -> m a) -> Err m a -> m a+handleError h m = do+ Right x <- runExceptT (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 :: (MonadFail 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+ [x] -> return x+ _ -> Fail.fail (err ++ ": '" ++ s ++ "'") -- -- Types for methods calls and responses -- --- | An XML-RPC method call. Consists of a method name and a list of +-- | 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 + 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 + | Fault Int String -- ^ A fault response+ deriving (Eq, Show) -- for debugging -- | An XML-RPC value.-data Value = - ValueInt Int -- ^ int or i4+data Value =+ ValueInt Int -- ^ int, i4, or i8 | ValueBool Bool -- ^ bool | ValueString String -- ^ string+ | ValueUnwrapped String -- ^ no inner element | ValueDouble Double -- ^ double | ValueDateTime LocalTime -- ^ dateTime.iso8601- | ValueBase64 String -- ^ base 64+ | ValueBase64 BS.ByteString -- ^ base 64. NOTE that you should provide the raw data; the haxr library takes care of doing the base-64 encoding. | ValueStruct [(String,Value)] -- ^ struct | ValueArray [Value] -- ^ array- deriving (Eq, Show) -- for debugging + | ValueNil -- ^ nil+ 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+data Type =+ TInt+ | TBool+ | TString+ | TDouble+ | TDateTime+ | TBase64+ | TStruct+ | TArray+ | TUnknown+ | TNil deriving (Eq) instance Show Type where@@ -182,37 +199,39 @@ show TStruct = "struct" show TArray = "array" show TUnknown = "unknown"+ show TNil = "nil" 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)]+ ("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)]+ ("nil",r) -> [(TNil,r)] -- | Gets the value of a struct member-structGetValue :: Monad m => String -> Value -> Err m Value-structGetValue n (ValueStruct t) = +structGetValue :: MonadFail 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 +-- | Builds a fault struct faultStruct :: Int -> String -> Value faultStruct code str = ValueStruct [("faultCode",ValueInt code),- ("faultString",ValueString str)]+ ("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"+onlyOneResult :: MonadFail m => [Value] -> Err m Value+onlyOneResult [] = Fail.fail "Method returned no result"+onlyOneResult [x] = return x+onlyOneResult _ = Fail.fail "Method returned more than one result" -- -- Converting to and from XML-RPC types@@ -224,23 +243,23 @@ 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+ fromValue :: MonadFail m => Value -> Err m a getType :: a -> Type -typeError :: (XmlRpcType a, Monad m) => Value -> Err m a+typeError :: (XmlRpcType a, MonadFail m) => Value -> Err m a typeError v = withType $ \t ->- fail ("Wanted: " - ++ show (getType t)- ++ "', got: '" - ++ showXml (toXRValue v) ++ "'") `asTypeOf` return t+ Fail.fail ("Wanted: "+ ++ show (getType t)+ ++ "', got: '"+ ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t -- a type hack for use in 'typeError' withType :: (a -> Err m a) -> Err m a withType f = f undefined -simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a) - -> Value -> Err m a-simpleFromValue f v = +simpleFromValue :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a)+ -> Value -> Err m a+simpleFromValue f v = maybe (typeError v) return (f v) @@ -256,37 +275,49 @@ instance XmlRpcType Int where toValue = ValueInt fromValue = simpleFromValue f- where f (ValueInt x) = Just x- f _ = Nothing+ 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+ where f (ValueBool x) = Just x+ f _ = Nothing getType _ = TBool -instance XmlRpcType String where+instance OVERLAPPING_ XmlRpcType String where toValue = ValueString fromValue = simpleFromValue f- where f (ValueString x) = Just x- f (ValueBase64 x) = Just x- f _ = Nothing+ where f (ValueString x) = Just x+ f (ValueUnwrapped x) = Just x+ f _ = Nothing getType _ = TString +instance XmlRpcType Text where+ toValue = ValueString . T.unpack+ fromValue = (liftM T.pack) . fromValue+ getType _ = TString++instance XmlRpcType BS.ByteString where+ toValue = ValueBase64+ fromValue = simpleFromValue f+ where f (ValueBase64 x) = Just x+ f _ = Nothing+ getType _ = TBase64+ instance XmlRpcType Double where toValue = ValueDouble fromValue = simpleFromValue f- where f (ValueDouble x) = Just x- f _ = Nothing+ where f (ValueDouble x) = Just x+ f _ = Nothing getType _ = TDouble instance XmlRpcType LocalTime where toValue = ValueDateTime fromValue = simpleFromValue f- where f (ValueDateTime x) = Just x- f _ = Nothing+ where f (ValueDateTime x) = Just x+ f _ = Nothing getType _ = TDateTime instance XmlRpcType CalendarTime where@@ -294,39 +325,79 @@ fromValue = liftM localTimeToCalendarTime . fromValue getType _ = TDateTime +instance XmlRpcType () where+ toValue = const ValueNil+ fromValue = simpleFromValue f+ where f ValueNil = Just ()+ f _ = Nothing+ getType _ = TNil+ -- FIXME: array elements may have different types-instance XmlRpcType a => XmlRpcType [a] where- toValue = ValueArray . map toValue +instance OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where+ toValue = ValueArray . map toValue fromValue v = case v of- ValueArray xs -> mapM fromValue xs- _ -> typeError v+ ValueArray xs -> mapM fromValue xs+ _ -> typeError v getType _ = TArray -- FIXME: struct elements may have different types-instance XmlRpcType a => XmlRpcType [(String,a)] where+instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs] fromValue v = case v of- ValueStruct xs -> mapM (\ (n,v) -> liftM ((,) n) (fromValue v)) xs- _ -> typeError v+ ValueStruct xs -> mapM (\ (n,v') -> liftM ((,) n) (fromValue v')) xs+ _ -> typeError v getType _ = TStruct +-- Tuple instances may be used for heterogenous array types.+instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d,+ XmlRpcType e) =>+ XmlRpcType (a,b,c,d,e) where+ toValue (v,w,x,y,z) =+ ValueArray [toValue v, toValue w, toValue x, toValue y, toValue z]+ fromValue (ValueArray [v,w,x,y,z]) =+ liftM5 (,,,,) (fromValue v) (fromValue w) (fromValue x)+ (fromValue y) (fromValue z)+ fromValue _ = throwError "Expected 5-element tuple!"+ getType _ = TArray++instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) =>+ XmlRpcType (a,b,c,d) where+ toValue (w,x,y,z) = ValueArray [toValue w, toValue x, toValue y, toValue z]+ fromValue (ValueArray [w,x,y,z]) =+ liftM4 (,,,) (fromValue w) (fromValue x) (fromValue y) (fromValue z)+ fromValue _ = throwError "Expected 4-element tuple!"+ getType _ = TArray++instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where+ toValue (x,y,z) = ValueArray [toValue x, toValue y, toValue z]+ fromValue (ValueArray [x,y,z]) =+ liftM3 (,,) (fromValue x) (fromValue y) (fromValue z)+ fromValue _ = throwError "Expected 3-element tuple!"+ getType _ = TArray++instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where+ toValue (x,y) = ValueArray [toValue x, toValue y]+ fromValue (ValueArray [x,y]) = liftM2 (,) (fromValue x) (fromValue y)+ fromValue _ = throwError "Expected 2-element tuple."+ getType _ = TArray+ -- | 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+getField :: (MonadFail 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)+getFieldMaybe :: (MonadFail 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@@ -336,13 +407,15 @@ toXRValue (ValueInt x) = XR.Value [XR.Value_AInt (XR.AInt (showInt x))] toXRValue (ValueBool b) = XR.Value [XR.Value_Boolean (XR.Boolean (showBool b))] toXRValue (ValueString s) = XR.Value [XR.Value_AString (XR.AString (showString s))]+toXRValue (ValueUnwrapped s) = XR.Value [XR.Value_Str s] toXRValue (ValueDouble d) = XR.Value [XR.Value_ADouble (XR.ADouble (showDouble d))]-toXRValue (ValueDateTime t) = +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) = +toXRValue (ValueArray xs) = XR.Value [XR.Value_Array (XR.Array (XR.Data (map toXRValue xs)))]+toXRValue ValueNil = XR.Value [XR.Value_Nil (XR.Nil ())] showInt :: Int -> String showInt = show@@ -350,9 +423,9 @@ showBool :: Bool -> String showBool b = if b then "1" else "0" --- escapes & and <+-- escapes &, <, and < showString :: String -> String-showString s = replace "<" "<" (replace "&" "&" s)+showString = replace ">" ">" . replace "<" "<" . replace "&" "&" -- | Shows a double in signed decimal point notation. showDouble :: Double -> String@@ -362,24 +435,19 @@ showDateTime :: LocalTime -> String showDateTime t = formatTime defaultTimeLocale xmlRpcDateFormat t -showBase64 :: String -> String-showBase64 = Base64.encode . stringToOctets- where- -- FIXME: this probably only works right for latin-1 strings- stringToOctets :: String -> [Word8]- stringToOctets = map (fromIntegral . fromEnum)-+showBase64 :: BS.ByteString -> String+showBase64 = BS.unpack . Base64.encode toXRMethodCall :: MethodCall -> XR.MethodCall-toXRMethodCall (MethodCall name vs) = +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) = +toXRMethodResponse (Fault code str) = XR.MethodResponseFault (XR.Fault (toXRValue (faultStruct code str))) -toXRParams :: [Value] -> XR.Params +toXRParams :: [Value] -> XR.Params toXRParams vs = XR.Params (map (XR.Param . toXRValue) vs) toXRMember :: (String, Value) -> XR.Member@@ -389,10 +457,10 @@ -- Converting from XR types -- -fromXRValue :: Monad m => XR.Value -> Err m Value+fromXRValue :: MonadFail m => XR.Value -> Err m Value fromXRValue (XR.Value vs) = case (filter notstr vs) of- [] -> liftM (ValueString . concat) (mapM (readString . unstr) vs)+ [] -> liftM (ValueUnwrapped . concat) (mapM (readString . unstr) vs) (v:_) -> f v where notstr (XR.Value_Str _) = False@@ -401,6 +469,7 @@ unstr (XR.Value_Str x) = x f (XR.Value_I4 (XR.I4 x)) = liftM ValueInt (readInt x)+ f (XR.Value_I8 (XR.I8 x)) = liftM ValueInt (readInt x) f (XR.Value_AInt (XR.AInt x)) = liftM ValueInt (readInt x) f (XR.Value_Boolean (XR.Boolean x)) = liftM ValueBool (readBool x) f (XR.Value_ADouble (XR.ADouble x)) = liftM ValueDouble (readDouble x)@@ -408,13 +477,14 @@ 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) + 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)+ f (XR.Value_Nil (XR.Nil x)) = return ValueNil -fromXRMember :: Monad m => XR.Member -> Err m (String,Value)+fromXRMember :: MonadFail 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:@@ -423,36 +493,36 @@ -- 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 :: MonadFail 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 :: MonadFail 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 _ = []+ 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) +-- 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 ">" ">"+ . 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,@@ -461,7 +531,7 @@ -- is implementation-dependent, is not specified. -- -- FIXME: accepts more than decimal point notation-readDouble :: Monad m => String -> Err m Double+readDouble :: MonadFail m => String -> Err m Double readDouble s = errorRead reads "Error parsing double" s -- | From <http://groups.yahoo.com/group/xml-rpc/message/4733>:@@ -470,61 +540,56 @@ -- 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 LocalTime+readDateTime :: MonadFail m => String -> Err m LocalTime readDateTime dt = maybe- (fail $ "Error parsing dateTime '" ++ dt ++ "'")+ (Fail.fail $ "Error parsing dateTime '" ++ dt ++ "'") return- (parseTime defaultTimeLocale xmlRpcDateFormat dt)+ (parseTimeM True defaultTimeLocale xmlRpcDateFormat dt) localTimeToCalendarTime :: LocalTime -> CalendarTime-localTimeToCalendarTime l = +localTimeToCalendarTime l = let (y,mo,d) = toGregorian (localDay l) TimeOfDay { todHour = h, todMin = mi, todSec = s } = localTimeOfDay l (_,_,wd) = toWeekDate (localDay l) (_,yd) = toOrdinalDate (localDay l) in CalendarTime {- ctYear = fromIntegral y,- ctMonth = toEnum (mo-1),- ctDay = d,- ctHour = h,- ctMin = mi,- ctSec = truncate s,- ctPicosec = 0,- ctWDay = toEnum (wd `mod` 7),- ctYDay = yd,- ctTZName = "UTC",- ctTZ = 0,- ctIsDST = False- }+ ctYear = fromIntegral y,+ ctMonth = toEnum (mo-1),+ ctDay = d,+ ctHour = h,+ ctMin = mi,+ ctSec = truncate s,+ ctPicosec = 0,+ ctWDay = toEnum (wd `mod` 7),+ ctYDay = yd,+ ctTZName = "UTC",+ ctTZ = 0,+ ctIsDST = False+ } calendarTimeToLocalTime :: CalendarTime -> LocalTime-calendarTimeToLocalTime ct = +calendarTimeToLocalTime ct = let (y,mo,d) = (ctYear ct, ctMonth ct, ctDay ct) (h,mi,s) = (ctHour ct, ctMin ct, ctSec ct)- in LocalTime { - localDay = fromGregorian (fromIntegral y) (fromEnum mo + 1) d, + in LocalTime {+ localDay = fromGregorian (fromIntegral y) (fromEnum mo + 1) d, localTimeOfDay = TimeOfDay { todHour = h, todMin = mi, todSec = fromIntegral s } } -- FIXME: what if data contains non-base64 characters?-readBase64 :: Monad m => String -> Err m String-readBase64 = return . octetsToString . Base64.decode- where- -- FIXME: this probably only works right for latin-1 strings- octetsToString :: [Word8] -> String- octetsToString = map (toEnum . fromIntegral)-+readBase64 :: Monad m => String -> Err m BS.ByteString+readBase64 = return . Base64.decode . BS.pack -fromXRParams :: Monad m => XR.Params -> Err m [Value]+fromXRParams :: MonadFail 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) = +fromXRMethodCall :: MonadFail 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) = +fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse+fromXRMethodResponse (XR.MethodResponseParams xps) = liftM Return (fromXRParams xps >>= onlyOneResult) fromXRMethodResponse (XR.MethodResponseFault (XR.Fault v)) = do@@ -537,22 +602,22 @@ -- -- Parsing calls and reponses from XML--- +-- -- | Parses a method call from XML.-parseCall :: Monad m => String -> Err m MethodCall-parseCall c = +parseCall :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodCall+parseCall c = do mxc <- errorToErr (readXml c)- xc <- maybeToM "Error parsing method call" mxc+ xc <- eitherToM "Error parsing method call" mxc fromXRMethodCall xc -- | Parses a method response from XML.-parseResponse :: Monad m => String -> Err m MethodResponse-parseResponse c = +parseResponse :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodResponse+parseResponse c = do mxr <- errorToErr (readXml c)- xr <- maybeToM "Error parsing method response" mxr+ xr <- eitherToM "Error parsing method response" mxr fromXRMethodResponse xr --@@ -561,10 +626,15 @@ -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML-renderCall :: MethodCall -> String-renderCall = showXml . toXRMethodCall+renderCall :: MethodCall -> BSL.ByteString+renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML-renderResponse :: MethodResponse -> String-renderResponse = showXml . toXRMethodResponse+renderResponse :: MethodResponse -> BSL.ByteString+renderResponse = showXml' False . toXRMethodResponse++showXml' :: XmlContent a => Bool -> a -> BSL.ByteString+showXml' dtd x = case toContents x of+ [CElem _ _] -> (document . toXml dtd) x+ _ -> BSL.pack ""
Network/XmlRpc/Introspect.hs view
@@ -1,7 +1,7 @@ module Network.XmlRpc.Introspect where -import Network.XmlRpc.Internals-import Network.XmlRpc.Client+import Network.XmlRpc.Client+import Network.XmlRpc.Internals type Signature = ([Type],Type) type Help = String@@ -21,11 +21,11 @@ signatures :: String -> String -> IO [Signature] signatures url name = do- sigs <- methodSignature url name- return [ (map read as,read r) | (r:as) <- sigs ]+ 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)+ sigs <- signatures url name+ help <- methodHelp url name+ return (name, sigs, help)
+ Network/XmlRpc/Pretty.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This is a fast non-pretty-printer for turning the internal representation+-- of generic structured XML documents into Lazy ByteStrings.+-- Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in+-- Text.Xml.HaXml.Types, so you can pretty-print as much or as little+-- of the document as you wish.++module Network.XmlRpc.Pretty (document, content, element,+ doctypedecl, prolog, cp) where++import Blaze.ByteString.Builder (Builder,+ fromLazyByteString,+ toLazyByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromString)+import Data.ByteString.Lazy.Char8 (ByteString, elem, empty)+import qualified Data.ByteString.Lazy.UTF8 as BU+import Data.Maybe (isNothing)+import Data.Monoid (Monoid, mappend, mconcat,+ mempty)+import Data.Semigroup (Semigroup)+import qualified GHC.Exts as Ext+import Prelude hiding (concat, elem, head,+ maybe, null)+import qualified Prelude as P+import Text.XML.HaXml.Types++-- |A 'Builder' with a recognizable empty value.+newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving (Semigroup, Monoid)++-- |'Maybe' eliminator specialized for 'MBuilder'.+maybe :: (t -> MBuilder) -> Maybe t -> MBuilder+maybe _ Nothing = mempty+maybe f (Just x) = f x++-- |Nullity predicate for 'MBuilder'.+null :: MBuilder -> Bool+null = isNothing . unMB++-- |Helper for injecting 'ByteString's into 'MBuilder'.+fromLBS :: ByteString -> MBuilder+fromLBS = MBuilder . Just . fromLazyByteString++-- Helper needed when using Data.Binary.Builder.+-- fromString :: String -> Builder+-- fromString = fromLazyByteString . BU.fromString++-- |Support for the OverloadedStrings extension to improve templating+-- syntax.+instance Ext.IsString MBuilder where+ fromString "" = mempty+ fromString s = MBuilder . Just . fromString $ s++-- Only define <> as mappend if not already provided in Prelude+#if !MIN_VERSION_base(4,11,0)+infixr 6 <>++-- |Beside.+(<>) :: MBuilder -> MBuilder -> MBuilder+(<>) = mappend+#endif++-- A simple implementation of the pretty-printing combinator interface,+-- but for plain ByteStrings:+infixr 6 <+>+infixr 5 $$++-- |Concatenate two 'MBuilder's with a single space in between+-- them. If either of the component 'MBuilder's is empty, then the+-- other is returned without any additional space.+(<+>) :: MBuilder -> MBuilder -> MBuilder+(<+>) b1 b2+ | null b2 = b1+ | null b1 = b2+ | otherwise = b1 <> " " <> b2++-- |Concatenate two 'MBuilder's with a single newline in between+-- them. If either of the component 'MBuilder's is empty, then the+-- other is returned without any additional newline.+($$) :: MBuilder -> MBuilder -> MBuilder+($$) b1 b2+ | null b2 = b1+ | null b1 = b2+ | otherwise = b1 <> "\n" <> b2++-- |Concatenate a list of 'MBuilder's with a given 'MBuilder' inserted+-- between each non-empty element of the list.+intercalate :: MBuilder -> [MBuilder] -> MBuilder+intercalate sep = aux . filter (not . null)+ where aux [] = mempty+ aux (x:xs) = x <> mconcat (map (sep <>) xs)++-- |List version of '<+>'.+hsep :: [MBuilder] -> MBuilder+hsep = intercalate " "++-- |List version of '$$'.+vcat :: [MBuilder] -> MBuilder+vcat = intercalate "\n"++hcatMap :: (a -> MBuilder) -> [a] -> MBuilder+hcatMap = (mconcat .) . map++vcatMap :: (a -> MBuilder) -> [a] -> MBuilder+vcatMap = (vcat .) . map++-- |``Paragraph fill'' version of 'sep'.+fsep :: [MBuilder] -> MBuilder+fsep = hsep++-- |Bracket an 'MBuilder' with parentheses.+parens :: MBuilder -> MBuilder+parens p = "(" <> p <> ")"++text :: String -> MBuilder+text = MBuilder . Just . fromString++name :: QName -> MBuilder+name = MBuilder . Just . fromString . unQ+ where unQ (QN (Namespace prefix uri) n) = prefix++":"++n+ unQ (N n) = n++----+-- Now for the XML pretty-printing interface.+-- (Basically copied direct from Text.XML.HaXml.Pretty).++-- |Render a 'Document' to a 'ByteString'.+document :: Document i -> ByteString+content :: Content i -> ByteString+element :: Element i -> ByteString+doctypedecl :: DocTypeDecl -> ByteString+prolog :: Prolog -> ByteString+cp :: CP -> ByteString++-- Builder variants of exported functions.+documentB :: Document i -> MBuilder+contentB :: Content i -> MBuilder+elementB :: Element i -> MBuilder+doctypedeclB :: DocTypeDecl -> MBuilder+prologB :: Prolog -> MBuilder+cpB :: CP -> MBuilder++xmldecl :: XMLDecl -> MBuilder+misc :: Misc -> MBuilder+sddecl :: Bool -> MBuilder+markupdecl :: MarkupDecl -> MBuilder+attribute :: Attribute -> MBuilder++-- |Run an 'MBuilder' to generate a 'ByteString'.+runMBuilder :: MBuilder -> ByteString+runMBuilder = aux . unMB+ where aux Nothing = empty+ aux (Just b) = toLazyByteString b++document = runMBuilder . documentB+content = runMBuilder . contentB+element = runMBuilder . elementB+doctypedecl = runMBuilder . doctypedeclB+prolog = runMBuilder . prologB+cp = runMBuilder . cpB++documentB (Document p _ e m) = prologB p $$ elementB e $$ vcatMap misc m++prologB (Prolog x m1 dtd m2) = maybe xmldecl x $$+ vcatMap misc m1 $$+ maybe doctypedeclB dtd $$+ vcatMap misc m2++xmldecl (XMLDecl v e sd) = "<?xml version='" <> text v <> "'" <+>+ maybe encodingdecl e <+>+ maybe sddecl sd <+> "?>"++misc (Comment s) = "<!--" <+> text s <+> "-->"+misc (PI (n,s)) = "<?" <> text n <+> text s <+> "?>"++sddecl sd | sd = "standalone='yes'"+ | otherwise = "standalone='no'"++doctypedeclB (DTD n eid ds) = if P.null ds then hd <> ">"+ else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>"+ where hd = "<!DOCTYPE" <+> name n <+> maybe externalid eid++markupdecl (Element e) = elementdecl e+markupdecl (AttList a) = attlistdecl a+markupdecl (Entity e) = entitydecl e+markupdecl (Notation n) = notationdecl n+markupdecl (MarkupMisc m) = misc m++elementB (Elem n as []) = "<" <> (name n <+> fsep (map attribute as)) <> "/>"+elementB (Elem n as cs@(c:_))+ | isText c = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>+ hcatMap contentB cs <> "</" <> name n <> ">"+ | otherwise = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>+ hcatMap contentB cs <> "</" <> name n <> ">"++isText :: Content t -> Bool+isText (CString _ _ _) = True+isText (CRef _ _) = True+isText _ = False++attribute (n,v) = name n <> "=" <> attvalue v++contentB (CElem e _) = elementB e+contentB (CString False s _) = chardata s+contentB (CString True s _) = cdsect s+contentB (CRef r _) = reference r+contentB (CMisc m _) = misc m++elementdecl :: ElementDecl -> MBuilder+elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> name n <+>+ contentspec cs <> ">"++contentspec :: ContentSpec -> MBuilder+contentspec EMPTY = "EMPTY"+contentspec ANY = "ANY"+contentspec (Mixed m) = mixed m+contentspec (ContentSpec c) = cpB c++cpB (TagName n m) = name n <> modifier m+cpB (Choice cs m) = parens (intercalate "|" (map cpB cs)) <> modifier m+cpB (Seq cs m) = parens (intercalate "," (map cpB cs)) <> modifier m++modifier :: Modifier -> MBuilder+modifier None = mempty+modifier Query = "?"+modifier Star = "*"+modifier Plus = "+"++mixed :: Mixed -> MBuilder+mixed PCDATA = "(#PCDATA)"+mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*"++attlistdecl :: AttListDecl -> MBuilder+attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> name n <+>+ fsep (map attdef ds) <> ">"++attdef :: AttDef -> MBuilder+attdef (AttDef n t d) = name n <+> atttype t <+> defaultdecl d++atttype :: AttType -> MBuilder+atttype StringType = "CDATA"+atttype (TokenizedType t) = tokenizedtype t+atttype (EnumeratedType t) = enumeratedtype t++tokenizedtype :: TokenizedType -> MBuilder+tokenizedtype ID = "ID"+tokenizedtype IDREF = "IDREF"+tokenizedtype IDREFS = "IDREFS"+tokenizedtype ENTITY = "ENTITY"+tokenizedtype ENTITIES = "ENTITIES"+tokenizedtype NMTOKEN = "NMTOKEN"+tokenizedtype NMTOKENS = "NMTOKENS"++enumeratedtype :: EnumeratedType -> MBuilder+enumeratedtype (NotationType n) = notationtype n+enumeratedtype (Enumeration e) = enumeration e++notationtype :: [[Char]] -> MBuilder+notationtype ns = "NOTATION" <+>+ parens (intercalate "|" (map text ns))++enumeration :: [[Char]] -> MBuilder+enumeration ns = parens (intercalate "|" (map nmtoken ns))++defaultdecl :: DefaultDecl -> MBuilder+defaultdecl REQUIRED = "#REQUIRED"+defaultdecl IMPLIED = "#IMPLIED"+defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a++reference :: Reference -> MBuilder+reference (RefEntity er) = entityref er+reference (RefChar cr) = charref cr++entityref :: [Char] -> MBuilder+entityref n = "&" <> text n <> ";"++charref :: (Show a) => a -> MBuilder+charref c = "&#" <> text (show c) <> ";"++entitydecl :: EntityDecl -> MBuilder+entitydecl (EntityGEDecl d) = gedecl d+entitydecl (EntityPEDecl d) = pedecl d++gedecl :: GEDecl -> MBuilder+gedecl (GEDecl n ed) = "<!ENTITY" <+> text n <+> entitydef ed <> ">"++pedecl :: PEDecl -> MBuilder+pedecl (PEDecl n pd) = "<!ENTITY %" <> text n <+> pedef pd <> ">"++entitydef :: EntityDef -> MBuilder+entitydef (DefEntityValue ew) = entityvalue ew+entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd++pedef :: PEDef -> MBuilder+pedef (PEDefEntityValue ew) = entityvalue ew+pedef (PEDefExternalID eid) = externalid eid++externalid :: ExternalID -> MBuilder+externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl+externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl++ndatadecl :: NDataDecl -> MBuilder+ndatadecl (NDATA n) = "NDATA" <+> text n++notationdecl :: NotationDecl -> MBuilder+notationdecl (NOTATION n e) = "<!NOTATION" <+> text n <+>+ either externalid publicid e <> ">"++publicid :: PublicID -> MBuilder+publicid (PUBLICID p) = "PUBLICID" <+> pubidliteral p++encodingdecl :: EncodingDecl -> MBuilder+encodingdecl (EncodingDecl s) = "encoding='" <> text s <> "'"++nmtoken :: [Char] -> MBuilder+nmtoken s = text s++attvalue :: AttValue -> MBuilder+attvalue (AttValue esr) = "\"" <> hcatMap attVal esr <> "\""+ where attVal = either text reference++entityvalue :: EntityValue -> MBuilder+entityvalue (EntityValue evs)+ | containsDoubleQuote evs = "'" <> hcatMap ev evs <> "'"+ | otherwise = "\"" <> hcatMap ev evs <> "\""++ev :: EV -> MBuilder+ev (EVString s) = text s+ev (EVRef r) = reference r++pubidliteral :: PubidLiteral -> MBuilder+pubidliteral (PubidLiteral s)+ | '"' `elem` s' = "'" <> fromLBS s' <> "'"+ | otherwise = "\"" <> fromLBS s' <> "\""+ where s' = BU.fromString s++systemliteral :: SystemLiteral -> MBuilder+systemliteral (SystemLiteral s)+ | '"' `elem` s' = "'" <> fromLBS s' <> "'"+ | otherwise = "\"" <> fromLBS s' <> "\""+ where s' = BU.fromString s++chardata, cdsect :: [Char] -> MBuilder+chardata s = {-if all isSpace s then empty else-} text s+cdsect c = "<![CDATA[" <> chardata c <> "]]>"++containsDoubleQuote :: [EV] -> Bool+containsDoubleQuote evs = any csq evs+ where csq (EVString s) = '"' `elem` BU.fromString s+ csq _ = False
Network/XmlRpc/Server.hs view
@@ -3,7 +3,7 @@ -- 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)@@ -13,7 +13,7 @@ -- -- A simple CGI-based XML-RPC server application: ----- > import Network.XmlRpc.Server +-- > import Network.XmlRpc.Server -- > -- > add :: Int -> Int -> IO Int -- > add x y = return (x + y)@@ -21,19 +21,23 @@ -- > main = cgiXmlRpcServer [("examples.add", fun add)] ----------------------------------------------------------------------------- -module Network.XmlRpc.Server +module Network.XmlRpc.Server ( XmlRpcMethod, ServerResult, fun, handleCall, methods, cgiXmlRpcServer, ) where -import Network.XmlRpc.Internals+import Network.XmlRpc.Internals -import Data.Maybe-import Control.Monad.Error-import Control.Exception+import qualified Codec.Binary.UTF8.String as U+import Control.Exception+import Control.Monad.Trans+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as B+import System.IO +serverName :: String serverName = "Haskell XmlRpcServer/0.1" --@@ -47,8 +51,8 @@ -- | The type of XML-RPC methods on the server. type XmlRpcMethod = (MethodCall -> ServerResult, Signature) -showException :: Exception -> String-showException ex = fromMaybe (show ex) (userErrors ex)+showException :: SomeException -> String+showException = show handleIO :: IO a -> Err IO a handleIO io = lift (try io) >>= either (fail . showException) return@@ -58,8 +62,8 @@ -- Converting Haskell functions to XML-RPC methods -- --- | Turns any function --- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => +-- | Turns any function+-- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ -- into an 'XmlRpcMethod' fun :: XmlRpcFun a => a -> XmlRpcMethod@@ -71,15 +75,15 @@ instance XmlRpcType a => XmlRpcFun (IO a) where toFun x (MethodCall _ []) = do- v <- handleIO x- return (Return (toValue v))+ v <- handleIO x+ return (Return (toValue v)) toFun _ _ = fail "Too many arguments" sig x = ([], getType (mType x)) 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)+ v <- fromValue x+ toFun (f v) (MethodCall n xs) toFun _ _ = fail "Too few arguments" sig f = let (a,b) = funType f (as, r) = sig b@@ -98,22 +102,21 @@ -- | 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)+handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString+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 _) = +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 :: [(String,XmlRpcMethod)] -> String -> IO ByteString server t = handleCall (methods (addIntrospection t)) @@ -123,16 +126,16 @@ -- 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+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 = +methodSignature t name = do (_,(as,r)) <- maybeToM ("Unknown method: " ++ name) (lookup name t) return [map show (r:as)]@@ -145,7 +148,7 @@ -- FIXME: implement help :: XmlRpcMethod -> String-help m = ""+help _ = "" --@@ -157,13 +160,16 @@ -- followed by the response to standard output. Supports -- introspection. cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO ()-cgiXmlRpcServer ms = +cgiXmlRpcServer ms = do- input <- getContents+ hSetBinaryMode stdin True+ hSetBinaryMode stdout True+ input <- U.decodeString `fmap` getContents+ --output <- U.encodeString `fmap` server ms input output <- server ms input putStr ("Server: " ++ serverName ++ crlf) putStr ("Content-Type: text/xml" ++ crlf)- putStr ("Content-Length: " ++ show (length output) ++ crlf)+ putStr ("Content-Length: " ++ show (B.length output) ++ crlf) putStr crlf- putStr output- where crlf = "\r\n"+ B.putStr output+ where crlf = "\r\n"
+ Network/XmlRpc/THDeriveXmlRpcType.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XmlRpc.THDeriveXmlRpcType+-- Copyright : (c) Bjorn Bringert 2003-2005+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (requires extensions and non-portable libraries)+--+-- Uses Template Haskell to automagically derive instances of 'XmlRpcType'+--+------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where++import Control.Monad (liftM, replicateM)+import Data.List (genericLength)+import Data.Maybe (maybeToList)+import Language.Haskell.TH+import Network.XmlRpc.Internals hiding (Type)++-- | Creates an 'XmlRpcType' instance which handles a Haskell record+-- as an XmlRpc struct. Example:+-- @+-- data Person = Person { name :: String, age :: Int }+-- $(asXmlRpcStruct \'\'Person)+-- @+asXmlRpcStruct :: Name -> Q [Dec]+asXmlRpcStruct name =+ do+ info <- reify name+ dec <- case info of+ TyConI d -> return d+ _ -> fail $ show name ++ " is not a type constructor"+ mkInstance dec++mkInstance :: Dec -> Q [Dec]+#if MIN_VERSION_template_haskell(2,11,0)+mkInstance (DataD _ n _ _ [RecC c fs] _) =+#else+mkInstance (DataD _ n _ [RecC c fs] _) =+#endif+ do+ let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs)+ tv <- mkToValue ns+ fv <- mkFromValue c ns+ gt <- mkGetType+ liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType)+ (conT n))+ (map return $ concat [tv, fv, gt])++mkInstance _ = error "Can only derive XML-RPC type for simple record types"+++isMaybe :: Type -> Bool+isMaybe (AppT (ConT n) _) | n == ''Maybe = True+isMaybe _ = False+++unqual :: Name -> Name+unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show++mkToValue :: [(Name,Bool)] -> Q [Dec]+mkToValue fs =+ do+ p <- newName "p"+ simpleFun 'toValue [varP p]+ (appE (varE 'toValue)+ (appE [| concat |] $ listE $ map (fieldToTuple p) fs))+++simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec]+simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]]++fieldToTuple :: Name -> (Name,Bool) -> ExpQ+fieldToTuple p (n,False) = listE [tupE [stringE (show n),+ appE (varE 'toValue)+ (appE (varE n) (varE p))+ ]+ ]+fieldToTuple p (n,True) =+ [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |]++mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]+mkFromValue c fs =+ do+ names <- replicateM (length fs) (newName "x")+ v <- newName "v"+ t <- newName "t"+ simpleFun 'fromValue [varP v] $+ doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] +++ zipWith (mkGetField t) (map varP names) fs +++ [noBindS $ appE [| return |] $ appsE (conE c:map varE names)]++mkGetField t p (f,False) = bindS p (appsE [varE 'getField,+ stringE (show f), varE t])+mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe,+ stringE (show f), varE t])++mkGetType :: Q [Dec]+mkGetType = simpleFun 'getType [wildP]+ (conE 'TStruct)
+ examples/Makefile view
@@ -0,0 +1,20 @@+GHC = ghc+GHCFLAGS = -O2 -package haxr -XOverlappingInstances++TEST_PROGS = make-stubs parse_response \+ person_server person_client raw_call \+ simple_client simple_server test_client \+ test_server time-xmlrpc-com validate \+ person_server person_client++.SUFFIXES: .hs .hi .o++.PHONY: all clean++default all: $(TEST_PROGS)++%: %.hs+ $(GHC) $(GHCFLAGS) --make -o $@ $<++clean:+ -rm -f *.hi *.o $(TEST_PROGS)
+ examples/Person.hs view
@@ -0,0 +1,22 @@+-- | This module demonstrates how to handle heterogeneous structs.+-- See person_server.hs and person_client.hs for examples.+module Person where++import Network.XmlRpc.Internals++-- | Record type used to represent the struct in Haskell.+data Person = Person { name :: String, age :: Int, spouse :: Maybe String } deriving Show++-- | Converts a Person to and from a heterogeneous struct.+-- Uses the existing instance of XmlRpcType for [(String,Value)]+instance XmlRpcType Person where+ toValue p = toValue $ [("name",toValue (name p)),+ ("age", toValue (age p))]+ ++ maybe [] ((:[]) . (,) "spouse" . toValue) (spouse p)+ fromValue v = do+ t <- fromValue v+ n <- getField "name" t+ a <- getField "age" t+ s <- getFieldMaybe "spouse" t+ return Person { name = n, age = a, spouse = s }+ getType _ = TStruct
+ examples/PersonTH.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fth #-}++-- | This module demonstrates how to handle heterogeneous structs+-- using Template Haskell.+-- See person_server.hs and person_client.hs for examples.+module PersonTH where++import Network.XmlRpc.Internals+import Network.XmlRpc.THDeriveXmlRpcType++-- | Record type used to represent the struct in Haskell.+data Person = Person { name :: String, age :: Int, spouse :: Maybe String } deriving Show++$(asXmlRpcStruct ''Person)
+ examples/make-stubs.hs view
@@ -0,0 +1,71 @@+-- Connects to an XML-RPC server that supports introspection+-- and prints a Haskell module to standard output that contains+-- stubs for all the methods available at the server.++import Network.XmlRpc.Internals+import Network.XmlRpc.Client+import Network.XmlRpc.Introspect++import Data.List+import System.Exit (exitFailure)+import System.Environment (getArgs)+import System.IO +import Text.PrettyPrint.HughesPJ++showHaskellType :: Type -> String+showHaskellType TInt = "Int"+showHaskellType TBool = "Bool"+showHaskellType TString = "String"+showHaskellType TDouble = "Double"+showHaskellType TDateTime = "CalendarTime"+showHaskellType TBase64 = "String"+showHaskellType TStruct = "[(String,Value)]"+showHaskellType TArray = "[Value]"+showHaskellType TUnknown = error "unknown type"++showHdr :: String -> String -> Doc+showHdr mod url = text "module" <+> text mod <+> text "where" + $$ text "import Network.XmlRpc.Client" + $$ text "import Network.XmlRpc.Internals (Value)"+ $$ text "import System.Time (CalendarTime)"+ $$ text ""+ $$ text "server :: String" + $$ text "server =" <+> doubleQuotes (text url)++showStub :: MethodInfo -> Doc+showStub (name,[(as,ret)],help) = + text "" $$ text "{-" <+> text help <+> text "-}"+ $$ text hsname <+> text "::" <+> hsep (intersperse (text "->") ft)+ $$ text hsname <+> text "= remote server" <+> doubleQuotes (text name)+ where + hsname = mkname name+ ft = map (text . showHaskellType) as + ++ [text "IO" <+> text (showHaskellType ret)]+ mkname [] = []+ mkname ('.':xs) = '_':mkname xs+ mkname (x:xs) = x:mkname xs+showStub (name, _, _) = error (name ++ " is overloaded")++printStub :: String -> String -> IO ()+printStub url method = methodInfo url method >>= putStrLn . show . showStub++printModule :: String -> String -> IO ()+printModule mod url = do+ ms <- listMethods url+ putStrLn $ show $ showHdr mod url+ mapM_ (printStub url) ms++parseArgs :: IO (String,String)+parseArgs = do+ args <- getArgs+ case args of + [mod,url] -> return (mod,url)+ _ -> do+ hPutStrLn stderr "Usage: make-stubs module-name url"+ exitFailure++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ (mod,url) <- parseArgs+ printModule mod url
+ examples/parse_response.hs view
@@ -0,0 +1,9 @@+-- Reads a method response in XML from standard input and prints its+-- internal representation to standard output.++import Network.XmlRpc.Internals++main = do+ c <- getContents+ r <- handleError fail (parseResponse c)+ putStrLn (show r)
+ examples/person_client.hs view
@@ -0,0 +1,13 @@+-- | Example client using a heterogeneous struct.++import Network.XmlRpc.Client+import PersonTH++server = "http://localhost/~bjorn/cgi-bin/person_server"++listPeople :: IO [Person]+listPeople = remote server "listPeople"++main = do+ people <- listPeople+ mapM_ print people
+ examples/person_server.hs view
@@ -0,0 +1,13 @@+-- | Example server using a heterogeneous struct.++import Network.XmlRpc.Server+import PersonTH++listPeople :: IO [Person]+listPeople = return [+ Person { name = "Homer Simpson", age = 38, + spouse = Just "Marge Simpson" },+ Person { name = "Lisa Simpson", age = 8, spouse = Nothing}+ ]++main = cgiXmlRpcServer [("listPeople", fun listPeople)]
+ examples/raw_call.hs view
@@ -0,0 +1,77 @@+-- Reads a method call in XML from standard input, sends it to a+-- server and prints the response to standard output. Must be editied +-- to use the right server URL.++import Data.Char+import Network.URI+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++import Network.XmlRpc.Internals+import Network.HTTP+import Network.Stream++parseArgs :: IO String+parseArgs = do+ args <- getArgs+ case args of + [url] -> return url+ _ -> do+ hPutStrLn stderr "Usage: raw_call url"+ exitFailure++main = do+ url <- parseArgs+ c <- getContents+ post url c+ return ()++++userAgent :: String+userAgent = "Haskell XmlRpcClient/0.1"++-- | Handle connection errors.+handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a+handleE h (Left e) = h e+handleE _ (Right v) = return v++post :: String -> String -> IO String+post url content = + case parseURI url of+ Nothing -> fail ("Bad uri: '" ++ url ++ "'")+ Just uri -> post_ uri content++post_ :: URI -> String -> IO String+post_ uri content = + do+ putStrLn "-- Begin request --"+ putStrLn (show (request uri content))+ putStrLn content+ putStrLn "-- End request --"+ eresp <- simpleHTTP (request uri content)+ resp <- handleE (fail . show) eresp+ case rspCode resp of+ (2,0,0) -> do+ putStrLn "-- Begin response --"+ putStrLn (show resp)+ putStrLn (rspBody resp)+ putStrLn "-- End response --"+ return (rspBody resp)+ _ -> fail (httpError resp)+ where+ showRspCode (a,b,c) = map intToDigit [a,b,c]+ httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp++-- | Create an XML-RPC compliant HTTP request+request :: URI -> String -> Request String+request uri content = Request{ rqURI = uri, + rqMethod = POST, + rqHeaders = headers, + rqBody = content }+ where+ -- the HTTP module adds a Host header based on the URI+ headers = [Header HdrUserAgent userAgent,+ Header HdrContentType "text/xml",+ Header HdrContentLength (show (length content))]
+ examples/simple_client.hs view
@@ -0,0 +1,14 @@+-- A client for simple_server++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)
+ examples/simple_server.hs view
@@ -0,0 +1,8 @@+-- A minimal server++import Network.XmlRpc.Server++add :: Int -> Int -> IO Int+add x y = return (x + y)++main = cgiXmlRpcServer [("examples.add", fun add)]
+ examples/test_client.hs view
@@ -0,0 +1,38 @@+-- A simple client that calls the methods in test_server.hs++import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)+import System.Time++import Network.XmlRpc.Client++time :: String -> IO CalendarTime+time url = remote url "examples.time"++add :: String -> Int -> Int -> IO Int+add url = remote url "examples.add"++fault :: String -> IO Int+fault url = remote url "echo.fault"+++parseArgs :: IO (String, Int, Int)+parseArgs = do+ args <- getArgs+ case args of+ [url,x,y] -> return (url, read x, read y)+ _ -> do+ hPutStrLn stderr "Usage: test_client url x y"+ exitFailure++main = do+ (url, x, y) <- parseArgs+ t <- time url+ putStrLn ("The server's current time is " ++ calendarTimeToString t) + z <- add url x y+ putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z)+ putStrLn "And now for an error:"+ fault url+ return ()+
+ examples/test_server.hs view
@@ -0,0 +1,18 @@+-- A simple server++import System.Time+import Network.XmlRpc.Server++add :: Int -> Int -> IO Int+add x y = return (x + y)++time :: IO CalendarTime+time = getClockTime >>= toCalendarTime++fault :: IO Int -- dummy+fault = fail "blaha"++main = cgiXmlRpcServer [+ ("examples.add", fun add),+ ("echo.fault", fun fault),+ ("examples.time", fun time)]
+ examples/time-xmlrpc-com.hs view
@@ -0,0 +1,11 @@+import Network.XmlRpc.Client+import System.Time++server = "http://time.xmlrpc.com/RPC2"++currentTime :: IO CalendarTime+currentTime = remote server "currentTime.getCurrentTime"++main = do+ t <- currentTime+ putStrLn (calendarTimeToString t)
+ examples/validate.hs view
@@ -0,0 +1,71 @@+-- Implements the validation suite from http://validator.xmlrpc.com/+-- This has not been tested as the XML-RPC validator does not seem to +-- be working at the moment.++import System.Time+import Network.XmlRpc.Internals+import Network.XmlRpc.Server++get :: String -> [(String,a)] -> IO a+get f xs = maybeToM ("No such field: '" ++ f ++ "'") (lookup f xs)++arrayOfStructsTest :: [[(String,Int)]] -> IO Int +arrayOfStructsTest xs = return $ sum [ i | Just i <- map (lookup "curly") xs]++countTheEntities :: String -> IO [(String,Int)]+countTheEntities xs = return [+ ("ctLeftAngleBrackets", count '<'),+ ("ctRightAngleBrackets", count '>'),+ ("ctAmpersands", count '&'),+ ("ctApostrophes", count '\''),+ ("ctQuotes", count '"')+ ]+ where count c = length (filter (==c) xs)++easyStructTest :: [(String,Int)] -> IO Int +easyStructTest xs = do+ m <- get "moe" xs+ l <- get "larry" xs+ c <- get "curly" xs+ return (m+l+c)++-- FIXME: should be able to get it as a struct+echoStructTest :: Value -> IO Value+echoStructTest xs = return xs++manyTypesTest :: Int -> Bool -> String -> Double -> CalendarTime -> String+ -> IO [Value]+manyTypesTest i b s d t b64 = return [toValue i, toValue b, toValue s,+ toValue d, toValue t, toValue b64]++moderateSizeArrayCheck :: [String] -> IO String+moderateSizeArrayCheck [] = fail "empty array"+moderateSizeArrayCheck xs = return (head xs ++ last xs)++nestedStructTest :: [(String,[(String,[(String,[(String,Int)])])])] -> IO Int+nestedStructTest c = do+ y <- get "2000" c+ m <- get "04" y+ d <- get "01" m+ easyStructTest d+++simpleStructReturnTest :: Int -> IO [(String, Int)]+simpleStructReturnTest x = return [+ ("times10",10*x),+ ("times100",100*x),+ ("times1000",1000*x)+ ]++main = cgiXmlRpcServer + [+ ("validator1.arrayOfStructsTest", fun arrayOfStructsTest),+ ("validator1.countTheEntities", fun countTheEntities),+ ("validator1.easyStructTest", fun easyStructTest),+ ("validator1.echoStructTest", fun echoStructTest),+ ("validator1.manyTypesTest", fun manyTypesTest),+ ("validator1.moderateSizeArrayCheck", fun moderateSizeArrayCheck),+ ("validator1.nestedStructTest", fun nestedStructTest),+ ("validator1.simpleStructReturnTest", fun simpleStructReturnTest)+ ]+
haxr.cabal view
@@ -1,31 +1,75 @@ Name: haxr-Version: 3000.2.1-Cabal-version: >=1.2+Version: 3000.11.6.1+Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 License: BSD3 License-file: LICENSE Author: Bjorn Bringert <bjorn@bringert.net>-Maintainer: Bjorn Bringert <bjorn@bringert.net>-Homepage: http://www.haskell.org/haxr/+Maintainer: Brent Yorgey <byorgey@gmail.com>+Homepage: http://www.haskell.org/haskellwiki/HaXR Category: Network Synopsis: XML-RPC client and server library. Description:- HaXR is a library for writing XML-RPC + HaXR is a library for writing XML-RPC client and server applications in Haskell. -flag old-base- description: Old, monolithic base- default: False+Extra-Source-Files:+ CHANGES+ examples/make-stubs.hs examples/parse_response.hs examples/Person.hs+ examples/PersonTH.hs examples/person_client.hs examples/person_server.hs+ examples/raw_call.hs examples/simple_client.hs examples/simple_server.hs+ examples/test_client.hs examples/test_server.hs examples/time-xmlrpc-com.hs+ examples/validate.hs examples/Makefile+Bug-reports: https://github.com/byorgey/haxr/issues+Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.2 || ==9.12.2 || ==9.14.1 +Source-repository head+ type: git+ location: https://github.com/byorgey/haxr++flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ Library- Build-depends: base < 4, mtl, network, HaXml >= 1.13, HTTP >= 4000, dataenc, old-locale, old-time, time, array+ Build-depends: base >= 4.9 && < 5,+ base-compat >= 0.8 && < 1,+ mtl < 3,+ mtl-compat,+ network < 4,+ http-streams,+ HsOpenSSL,+ io-streams,+ http-types,+ HaXml >= 1.22,+ http-streams,+ bytestring,+ base64-bytestring,+ old-locale,+ old-time,+ time,+ text,+ array,+ utf8-string,+ template-haskell,+ blaze-builder >= 0.2++ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network-uri < 2.6, network < 2.6+ Exposed-Modules: Network.XmlRpc.Client, Network.XmlRpc.Server, Network.XmlRpc.Internals,- Network.XmlRpc.Introspect- Other-Modules:- Network.XmlRpc.Base64,+ Network.XmlRpc.Introspect,+ Network.XmlRpc.THDeriveXmlRpcType,+ Network.XmlRpc.Pretty, Network.XmlRpc.DTD_XMLRPC- Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances+ Other-Modules:+ Network.XmlRpc.Base64+ Default-extensions: TypeSynonymInstances, FlexibleInstances+ Other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell+ Default-language: Haskell2010