haxr 3000.8.2 → 3000.11.6.1
raw patch · 14 files changed
Files
- CHANGES +173/−0
- Network/XmlRpc/Base64.hs +6/−3
- Network/XmlRpc/Client.hs +144/−89
- Network/XmlRpc/DTD_XMLRPC.hs +68/−39
- Network/XmlRpc/Internals.hs +250/−218
- Network/XmlRpc/Introspect.hs +7/−7
- Network/XmlRpc/Pretty.hs +82/−66
- Network/XmlRpc/Server.hs +26/−26
- Network/XmlRpc/THDeriveXmlRpcType.hs +40/−34
- examples/Makefile +1/−1
- examples/raw_call.hs +3/−2
- examples/test_client.hs +4/−3
- examples/test_server.hs +1/−1
- haxr.cabal +48/−12
+ 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,73 +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)-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 Data.ByteString.Lazy.Char8 (ByteString, toChunks, fromChunks)-import qualified Data.ByteString.UTF8 as U-import qualified Data.ByteString as BS+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@@ -110,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 -> ByteString -> 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 -> ByteString -> IO String-post_ uri auth content = - do- -- FIXME: remove- --putStrLn (show (request uri content))- --putStrLn content- eresp <- simpleHTTP (request uri auth (BS.concat . toChunks $ content))- resp <- handleE (fail . show) eresp- case rspCode resp of- (2,0,0) -> return (U.toString (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 -> BS.ByteString -> Request BS.ByteString-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 (BS.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,27 +1,31 @@ module Network.XmlRpc.DTD_XMLRPC where -import Text.XML.HaXml.XmlContent-import Text.XML.HaXml.OneOfN+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 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)+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 Value = Value [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@@ -30,13 +34,14 @@ | 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)+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)+newtype Fault = Fault Value deriving (Eq,Show) data MethodResponse = MethodResponseParams Params | MethodResponseFault Fault deriving (Eq,Show)@@ -48,17 +53,27 @@ toHType x = Defined "i4" [] [] instance XmlContent I4 where toContents (I4 a) =- [CElem (Elem "i4" [] (toText 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 "int" [] (toText a)) ()]+ [CElem (Elem (N "int") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["int"] ; interior e $ return (AInt) `apply` (text `onFail` return "")@@ -68,7 +83,7 @@ toHType x = Defined "boolean" [] [] instance XmlContent Boolean where toContents (Boolean a) =- [CElem (Elem "boolean" [] (toText a)) ()]+ [CElem (Elem (N "boolean") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["boolean"] ; interior e $ return (Boolean) `apply` (text `onFail` return "")@@ -78,7 +93,7 @@ toHType x = Defined "string" [] [] instance XmlContent AString where toContents (AString a) =- [CElem (Elem "string" [] (toText a)) ()]+ [CElem (Elem (N "string") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["string"] ; interior e $ return (AString) `apply` (text `onFail` return "")@@ -88,7 +103,7 @@ toHType x = Defined "double" [] [] instance XmlContent ADouble where toContents (ADouble a) =- [CElem (Elem "double" [] (toText a)) ()]+ [CElem (Elem (N "double") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["double"] ; interior e $ return (ADouble) `apply` (text `onFail` return "")@@ -98,18 +113,28 @@ toHType x = Defined "dateTime.iso8601" [] [] instance XmlContent DateTime_iso8601 where toContents (DateTime_iso8601 a) =- [CElem (Elem "dateTime.iso8601" [] (toText 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 "base64" [] (toText a)) ()]+ [CElem (Elem (N "base64") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["base64"] ; interior e $ return (Base64) `apply` (text `onFail` return "")@@ -119,7 +144,7 @@ toHType x = Defined "data" [] [] instance XmlContent Data where toContents (Data a) =- [CElem (Elem "data" [] (concatMap toContents a)) ()]+ [CElem (Elem (N "data") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["data"] ; interior e $ return (Data) `apply` many parseContents@@ -129,7 +154,7 @@ toHType x = Defined "array" [] [] instance XmlContent Array where toContents (Array a) =- [CElem (Elem "array" [] (toContents a)) ()]+ [CElem (Elem (N "array") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["array"] ; interior e $ return (Array) `apply` parseContents@@ -139,7 +164,7 @@ toHType x = Defined "name" [] [] instance XmlContent Name where toContents (Name a) =- [CElem (Elem "name" [] (toText a)) ()]+ [CElem (Elem (N "name") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["name"] ; interior e $ return (Name) `apply` (text `onFail` return "")@@ -149,7 +174,7 @@ toHType x = Defined "member" [] [] instance XmlContent Member where toContents (Member a b) =- [CElem (Elem "member" [] (toContents a ++ toContents b)) ()]+ [CElem (Elem (N "member") [] (toContents a ++ toContents b)) ()] parseContents = do { e@(Elem _ [] _) <- element ["member"] ; interior e $ return (Member) `apply` parseContents@@ -160,7 +185,7 @@ toHType x = Defined "struct" [] [] instance XmlContent Struct where toContents (Struct a) =- [CElem (Elem "struct" [] (concatMap toContents a)) ()]+ [CElem (Elem (N "struct") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["struct"] ; interior e $ return (Struct) `apply` many parseContents@@ -170,7 +195,7 @@ toHType x = Defined "value" [] [] instance XmlContent Value where toContents (Value a) =- [CElem (Elem "value" [] (concatMap toContents a)) ()]+ [CElem (Elem (N "value") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["value"] ; interior e $ return (Value) `apply` many parseContents@@ -181,6 +206,7 @@ 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@@ -189,9 +215,11 @@ 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@@ -200,13 +228,14 @@ , 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 "param" [] (toContents a)) ()]+ [CElem (Elem (N "param") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["param"] ; interior e $ return (Param) `apply` parseContents@@ -216,7 +245,7 @@ toHType x = Defined "params" [] [] instance XmlContent Params where toContents (Params a) =- [CElem (Elem "params" [] (concatMap toContents a)) ()]+ [CElem (Elem (N "params") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["params"] ; interior e $ return (Params) `apply` many parseContents@@ -226,7 +255,7 @@ toHType x = Defined "methodName" [] [] instance XmlContent MethodName where toContents (MethodName a) =- [CElem (Elem "methodName" [] (toText a)) ()]+ [CElem (Elem (N "methodName") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["methodName"] ; interior e $ return (MethodName)@@ -237,7 +266,7 @@ toHType x = Defined "methodCall" [] [] instance XmlContent MethodCall where toContents (MethodCall a b) =- [CElem (Elem "methodCall" [] (toContents a +++ [CElem (Elem (N "methodCall") [] (toContents a ++ maybe [] toContents b)) ()] parseContents = do { e@(Elem _ [] _) <- element ["methodCall"]@@ -249,7 +278,7 @@ toHType x = Defined "fault" [] [] instance XmlContent Fault where toContents (Fault a) =- [CElem (Elem "fault" [] (toContents a)) ()]+ [CElem (Elem (N "fault") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["fault"] ; interior e $ return (Fault) `apply` parseContents@@ -259,10 +288,10 @@ toHType x = Defined "methodResponse" [] [] instance XmlContent MethodResponse where toContents (MethodResponseParams a) =- [CElem (Elem "methodResponse" [] (toContents a) ) ()]+ [CElem (Elem (N "methodResponse") [] (toContents a) ) ()] toContents (MethodResponseFault a) =- [CElem (Elem "methodResponse" [] (toContents a) ) ()]- parseContents = do + [CElem (Elem (N "methodResponse") [] (toContents a) ) ()]+ parseContents = do { e@(Elem _ [] _) <- element ["methodResponse"] ; interior e $ oneOf [ return (MethodResponseParams) `apply` parseContents
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.XmlContent-import Network.XmlRpc.Pretty-import Data.ByteString.Lazy.Char8 (ByteString, pack)+#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,29 +97,30 @@ | 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 :: (Show e, MonadError e m) => a -> Err m a@@ -108,68 +133,60 @@ 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 False (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,46 +325,53 @@ 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) => +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d,+ XmlRpcType e) => XmlRpcType (a,b,c,d,e) where- toValue (v,w,x,y,z) = + 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 (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) => +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]) = + 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]) = + fromValue (ValueArray [x,y,z]) = liftM3 (,,) (fromValue x) (fromValue y) (fromValue z) fromValue _ = throwError "Expected 3-element tuple!" getType _ = TArray@@ -345,21 +383,21 @@ 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@@ -369,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@@ -383,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@@ -395,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@@ -422,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@@ -434,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)@@ -441,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:@@ -456,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,@@ -494,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>:@@ -503,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@@ -570,19 +602,19 @@ -- -- Parsing calls and reponses from XML--- +-- -- | Parses a method call from XML.-parseCall :: (Show e, MonadError e 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 <- eitherToM "Error parsing method call" mxc fromXRMethodCall xc -- | Parses a method response from XML.-parseResponse :: (Show e, MonadError e 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 <- eitherToM "Error parsing method response" mxr@@ -594,15 +626,15 @@ -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML-renderCall :: MethodCall -> ByteString+renderCall :: MethodCall -> BSL.ByteString renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML-renderResponse :: MethodResponse -> ByteString+renderResponse :: MethodResponse -> BSL.ByteString renderResponse = showXml' False . toXRMethodResponse -showXml' :: XmlContent a => Bool -> a -> ByteString+showXml' :: XmlContent a => Bool -> a -> BSL.ByteString showXml' dtd x = case toContents x of [CElem _ _] -> (document . toXml dtd) x- _ -> pack ""+ _ -> 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
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+{-# 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.@@ -6,26 +8,31 @@ -- 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, +module Network.XmlRpc.Pretty (document, content, element, doctypedecl, prolog, cp) where -import Prelude hiding (maybe, elem, concat, null, head)-import qualified Prelude as P-import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty)-import qualified Data.ByteString.Lazy.UTF8 as BU-import Text.XML.HaXml.Types-import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromString)-import Data.Maybe (isNothing)-import Data.Monoid-import qualified GHC.Exts as Ext+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 Monoid+newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving (Semigroup, Monoid) -- |'Maybe' eliminator specialized for 'MBuilder'. maybe :: (t -> MBuilder) -> Maybe t -> MBuilder-maybe _ Nothing = mempty+maybe _ Nothing = mempty maybe f (Just x) = f x -- |Nullity predicate for 'MBuilder'.@@ -44,18 +51,22 @@ -- syntax. instance Ext.IsString MBuilder where fromString "" = mempty- fromString s = MBuilder . Just . fromString $ s+ fromString s = MBuilder . Just . fromString $ s --- A simple implementation of the pretty-printing combinator interface,--- but for plain ByteStrings:+-- Only define <> as mappend if not already provided in Prelude+#if !MIN_VERSION_base(4,11,0) infixr 6 <>-infixr 6 <+>-infixr 5 $$ -- |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.@@ -69,7 +80,7 @@ -- them. If either of the component 'MBuilder's is empty, then the -- other is returned without any additional newline. ($$) :: MBuilder -> MBuilder -> MBuilder-($$) b1 b2 +($$) b1 b2 | null b2 = b1 | null b1 = b2 | otherwise = b1 <> "\n" <> b2@@ -82,7 +93,7 @@ aux (x:xs) = x <> mconcat (map (sep <>) xs) -- |List version of '<+>'.-hsep :: [MBuilder] -> MBuilder +hsep :: [MBuilder] -> MBuilder hsep = intercalate " " -- |List version of '$$'.@@ -96,7 +107,7 @@ vcatMap = (vcat .) . map -- |``Paragraph fill'' version of 'sep'.-fsep :: [MBuilder] -> MBuilder +fsep :: [MBuilder] -> MBuilder fsep = hsep -- |Bracket an 'MBuilder' with parentheses.@@ -106,6 +117,11 @@ 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).@@ -135,7 +151,7 @@ -- |Run an 'MBuilder' to generate a 'ByteString'. runMBuilder :: MBuilder -> ByteString runMBuilder = aux . unMB- where aux Nothing = empty+ where aux Nothing = empty aux (Just b) = toLazyByteString b document = runMBuilder . documentB@@ -156,35 +172,35 @@ maybe encodingdecl e <+> maybe sddecl sd <+> "?>" -misc (Comment s) = "<!--" <+> text s <+> "-->"-misc (PI (n,s)) = "<?" <> text n <+> text s <+> "?>"+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" <+> text n <+> maybe externalid eid+ 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+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 []) = "<" <> (text n <+> fsep (map attribute as)) <> "/>"-elementB (Elem n as cs) - | isText (P.head cs) = "<" <> (text n <+> fsep (map attribute as)) <> ">" <>- hcatMap contentB cs <> "</" <> text n <> ">"- | otherwise = "<" <> (text n <+> fsep (map attribute as)) <> ">" <>- hcatMap contentB cs <> "</" <> text n <> ">"+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) = text n <> "=" <> attvalue v+attribute (n,v) = name n <> "=" <> attvalue v contentB (CElem e _) = elementB e contentB (CString False s _) = chardata s@@ -193,7 +209,7 @@ contentB (CMisc m _) = misc m elementdecl :: ElementDecl -> MBuilder-elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> text n <+>+elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> name n <+> contentspec cs <> ">" contentspec :: ContentSpec -> MBuilder@@ -202,7 +218,7 @@ contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cpB c -cpB (TagName n m) = text n <> modifier m+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 @@ -214,28 +230,28 @@ mixed :: Mixed -> MBuilder mixed PCDATA = "(#PCDATA)"-mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map text ns) <> ")*"+mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*" attlistdecl :: AttListDecl -> MBuilder-attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> text n <+> +attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> name n <+> fsep (map attdef ds) <> ">" attdef :: AttDef -> MBuilder-attdef (AttDef n t d) = text n <+> atttype t <+> defaultdecl d+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+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"+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@@ -249,13 +265,13 @@ 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+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+reference (RefEntity er) = entityref er+reference (RefChar cr) = charref cr entityref :: [Char] -> MBuilder entityref n = "&" <> text n <> ";"@@ -264,8 +280,8 @@ charref c = "&#" <> text (show c) <> ";" entitydecl :: EntityDecl -> MBuilder-entitydecl (EntityGEDecl d) = gedecl d-entitydecl (EntityPEDecl d) = pedecl d+entitydecl (EntityGEDecl d) = gedecl d+entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> MBuilder gedecl (GEDecl n ed) = "<!ENTITY" <+> text n <+> entitydef ed <> ">"@@ -278,12 +294,12 @@ entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> MBuilder-pedef (PEDefEntityValue ew) = entityvalue ew-pedef (PEDefExternalID eid) = externalid eid+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+externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl+externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> MBuilder ndatadecl (NDATA n) = "NDATA" <+> text n@@ -311,8 +327,8 @@ | otherwise = "\"" <> hcatMap ev evs <> "\"" ev :: EV -> MBuilder-ev (EVString s) = text s-ev (EVRef r) = reference r+ev (EVString s) = text s+ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> MBuilder pubidliteral (PubidLiteral s)
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,23 +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.ByteString.Lazy.Char8 (ByteString)+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 Data.Maybe-import Control.Monad.Error-import Control.Exception-import qualified Codec.Binary.UTF8.String as U-import System.IO+import System.IO +serverName :: String serverName = "Haskell XmlRpcServer/0.1" --@@ -62,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@@ -75,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@@ -104,12 +104,12 @@ -- to generate a response and returns that response as a string handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString handleCall f str = do resp <- errorToResponse (parseCall str >>= f)- return (renderResponse resp)+ 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@@ -126,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)]@@ -148,7 +148,7 @@ -- FIXME: implement help :: XmlRpcMethod -> String-help m = ""+help _ = "" --@@ -160,7 +160,7 @@ -- followed by the response to standard output. Supports -- introspection. cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO ()-cgiXmlRpcServer ms = +cgiXmlRpcServer ms = do hSetBinaryMode stdin True hSetBinaryMode stdout True@@ -172,4 +172,4 @@ putStr ("Content-Length: " ++ show (B.length output) ++ crlf) putStr crlf B.putStr output- where crlf = "\r\n"+ where crlf = "\r\n"
Network/XmlRpc/THDeriveXmlRpcType.hs view
@@ -3,7 +3,7 @@ -- 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)@@ -12,14 +12,16 @@ -- ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}+ module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where -import Control.Monad (replicateM, liftM)-import Data.List (genericLength)-import Data.Maybe (maybeToList)-import Language.Haskell.TH-import Network.XmlRpc.Internals hiding (Type)+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:@@ -28,24 +30,28 @@ -- $(asXmlRpcStruct \'\'Person) -- @ asXmlRpcStruct :: Name -> Q [Dec]-asXmlRpcStruct name = +asXmlRpcStruct name = do info <- reify name dec <- case info of- TyConI d -> return d- _ -> fail $ show name ++ " is not a type constructor"+ TyConI d -> return d+ _ -> fail $ show name ++ " is not a type constructor" mkInstance dec mkInstance :: Dec -> Q [Dec]-mkInstance (DataD _ n _ [RecC c fs] _) = +#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 + tv <- mkToValue ns fv <- mkFromValue c ns gt <- mkGetType liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType)- (conT n)) - (map return $ concat [tv, fv, gt])+ (conT n))+ (map return $ concat [tv, fv, gt]) mkInstance _ = error "Can only derive XML-RPC type for simple record types" @@ -59,42 +65,42 @@ unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show mkToValue :: [(Name,Bool)] -> Q [Dec]-mkToValue fs = +mkToValue fs = do p <- newName "p"- simpleFun 'toValue [varP p] - (appE (varE 'toValue)- (appE [| concat |] $ listE $ map (fieldToTuple p) fs))+ 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) = +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 = +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)]+ 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])+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)+mkGetType = simpleFun 'getType [wildP]+ (conE 'TStruct)
examples/Makefile view
@@ -1,5 +1,5 @@ GHC = ghc-GHCFLAGS = -O2 -package haxr -fallow-overlapping-instances+GHCFLAGS = -O2 -package haxr -XOverlappingInstances TEST_PROGS = make-stubs parse_response \ person_server person_client raw_call \
examples/raw_call.hs view
@@ -2,10 +2,11 @@ -- server and prints the response to standard output. Must be editied -- to use the right server URL. -import System (getArgs, exitFailure)-import IO (hPutStrLn, stderr) 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
examples/test_client.hs view
@@ -1,8 +1,9 @@ -- A simple client that calls the methods in test_server.hs -import System (getArgs, exitFailure)-import IO (hPutStrLn, stderr)-import Time+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)+import System.Time import Network.XmlRpc.Client
examples/test_server.hs view
@@ -1,6 +1,6 @@ -- A simple server -import Time+import System.Time import Network.XmlRpc.Server add :: Int -> Int -> IO Int
haxr.cabal view
@@ -1,39 +1,75 @@ Name: haxr-Version: 3000.8.2-Cabal-version: >=1.6+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: Gracjan Polak <gracjanpolak@gmail.com>+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. 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 < 5, mtl, network < 3, - HaXml == 1.20.*, HTTP >= 4000, bytestring, dataenc, - old-locale, old-time, time, array, utf8-string, - template-haskell, blaze-builder >= 0.2 && < 0.4+ 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, Network.XmlRpc.THDeriveXmlRpcType,- Network.XmlRpc.Pretty- Other-Modules:- Network.XmlRpc.Base64,+ Network.XmlRpc.Pretty, Network.XmlRpc.DTD_XMLRPC- Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances, TemplateHaskell+ Other-Modules:+ Network.XmlRpc.Base64+ Default-extensions: TypeSynonymInstances, FlexibleInstances+ Other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell+ Default-language: Haskell2010