diff --git a/CHANGES b/CHANGES
new file mode 100644
--- /dev/null
+++ b/CHANGES
@@ -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 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.*
+
diff --git a/Network/XmlRpc/Base64.hs b/Network/XmlRpc/Base64.hs
--- a/Network/XmlRpc/Base64.hs
+++ b/Network/XmlRpc/Base64.hs
@@ -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
diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs
--- a/Network/XmlRpc/Client.hs
+++ b/Network/XmlRpc/Client.hs
@@ -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
diff --git a/Network/XmlRpc/DTD_XMLRPC.hs b/Network/XmlRpc/DTD_XMLRPC.hs
--- a/Network/XmlRpc/DTD_XMLRPC.hs
+++ b/Network/XmlRpc/DTD_XMLRPC.hs
@@ -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 "" "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 "" "member" ca))
- (definite fromElem "" "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 "" "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 "" "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 "" "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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+
+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 , "++)
+ }
+
+
+
+{-Done-}
diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs
--- a/Network/XmlRpc/Internals.hs
+++ b/Network/XmlRpc/Internals.hs
@@ -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
-- , which can contain a single which contains a
-- single which contains a single ."
-onlyOneResult :: Monad m => [Value] -> Err m Value
-onlyOneResult [] = fail "Method returned no result"
-onlyOneResult [x] = return x
-onlyOneResult _ = fail "Method returned more than one result"
+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 :
@@ -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 ""
diff --git a/Network/XmlRpc/Introspect.hs b/Network/XmlRpc/Introspect.hs
--- a/Network/XmlRpc/Introspect.hs
+++ b/Network/XmlRpc/Introspect.hs
@@ -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)
diff --git a/Network/XmlRpc/Pretty.hs b/Network/XmlRpc/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/Network/XmlRpc/Pretty.hs
@@ -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) = " text v <> "'" <+>
+ maybe encodingdecl e <+>
+ maybe sddecl sd <+> "?>"
+
+misc (Comment 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 = " 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) = " 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) = " 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) = " text n <+> entitydef ed <> ">"
+
+pedecl :: PEDecl -> MBuilder
+pedecl (PEDecl n pd) = " 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) = " 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 = " chardata c <> "]]>"
+
+containsDoubleQuote :: [EV] -> Bool
+containsDoubleQuote evs = any csq evs
+ where csq (EVString s) = '"' `elem` BU.fromString s
+ csq _ = False
diff --git a/Network/XmlRpc/Server.hs b/Network/XmlRpc/Server.hs
--- a/Network/XmlRpc/Server.hs
+++ b/Network/XmlRpc/Server.hs
@@ -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"
diff --git a/Network/XmlRpc/THDeriveXmlRpcType.hs b/Network/XmlRpc/THDeriveXmlRpcType.hs
new file mode 100644
--- /dev/null
+++ b/Network/XmlRpc/THDeriveXmlRpcType.hs
@@ -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)
diff --git a/examples/Makefile b/examples/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/Makefile
@@ -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)
diff --git a/examples/Person.hs b/examples/Person.hs
new file mode 100644
--- /dev/null
+++ b/examples/Person.hs
@@ -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
diff --git a/examples/PersonTH.hs b/examples/PersonTH.hs
new file mode 100644
--- /dev/null
+++ b/examples/PersonTH.hs
@@ -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)
diff --git a/examples/make-stubs.hs b/examples/make-stubs.hs
new file mode 100644
--- /dev/null
+++ b/examples/make-stubs.hs
@@ -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
diff --git a/examples/parse_response.hs b/examples/parse_response.hs
new file mode 100644
--- /dev/null
+++ b/examples/parse_response.hs
@@ -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)
diff --git a/examples/person_client.hs b/examples/person_client.hs
new file mode 100644
--- /dev/null
+++ b/examples/person_client.hs
@@ -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
diff --git a/examples/person_server.hs b/examples/person_server.hs
new file mode 100644
--- /dev/null
+++ b/examples/person_server.hs
@@ -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)]
diff --git a/examples/raw_call.hs b/examples/raw_call.hs
new file mode 100644
--- /dev/null
+++ b/examples/raw_call.hs
@@ -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))]
diff --git a/examples/simple_client.hs b/examples/simple_client.hs
new file mode 100644
--- /dev/null
+++ b/examples/simple_client.hs
@@ -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)
diff --git a/examples/simple_server.hs b/examples/simple_server.hs
new file mode 100644
--- /dev/null
+++ b/examples/simple_server.hs
@@ -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)]
diff --git a/examples/test_client.hs b/examples/test_client.hs
new file mode 100644
--- /dev/null
+++ b/examples/test_client.hs
@@ -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 ()
+
diff --git a/examples/test_server.hs b/examples/test_server.hs
new file mode 100644
--- /dev/null
+++ b/examples/test_server.hs
@@ -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)]
diff --git a/examples/time-xmlrpc-com.hs b/examples/time-xmlrpc-com.hs
new file mode 100644
--- /dev/null
+++ b/examples/time-xmlrpc-com.hs
@@ -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)
diff --git a/examples/validate.hs b/examples/validate.hs
new file mode 100644
--- /dev/null
+++ b/examples/validate.hs
@@ -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)
+ ]
+
diff --git a/haxr.cabal b/haxr.cabal
--- a/haxr.cabal
+++ b/haxr.cabal
@@ -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
-Maintainer: Bjorn Bringert
-Homepage: http://www.haskell.org/haxr/
+Maintainer: Brent Yorgey
+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