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,73 +32,110 @@ module Network.XmlRpc.Client ( - remote, - call, + remote, remoteWithHeaders, + call, callWithHeaders, Remote ) where -import qualified Network.XmlRpc.Base64 as Base64 -import Network.XmlRpc.Internals +import Network.XmlRpc.Internals -import Control.Exception (handleJust) -import Data.Char -import Data.Maybe -import Data.Word (Word8) -import Network.URI -import Network.Socket (withSocketsDo) +import Control.Monad.Fail (MonadFail) +import qualified Control.Monad.Fail as Fail +import Data.Functor ((<$>)) +import Data.Int +import Data.List (uncons) +import Data.Maybe +import Network.URI +import Text.Read.Compat (readMaybe) -import Network.HTTP -import Network.Stream +import Network.Http.Client (Method (..), Request, + baselineContextSSL, buildRequest, + closeConnection, getStatusCode, + getStatusMessage, http, + inputStreamBody, openConnection, + openConnectionSSL, receiveResponse, + sendRequest, setAccept, + setAuthorizationBasic, + setContentLength, setContentType, + setHeader) +import OpenSSL +import qualified System.IO.Streams as Streams -import Data.ByteString.Lazy.Char8 (ByteString, toChunks, fromChunks) -import qualified Data.ByteString.UTF8 as U -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, fromChunks, + length, unpack) +import qualified Data.ByteString.Lazy.UTF8 as U -- | Gets the return value from a method response. -- Throws an exception if the response was a fault. -handleResponse :: Monad m => MethodResponse -> m Value -handleResponse (Return v) = return v +handleResponse :: MonadFail m => MethodResponse -> m Value +handleResponse (Return v) = return v handleResponse (Fault code str) = fail ("Error " ++ show code ++ ": " ++ str) +type HeadersAList = [(BS.ByteString, BS.ByteString)] + -- | Sends a method call to a server and returns the response. -- Throws an exception if the response was an error. -doCall :: String -> MethodCall -> Err IO MethodResponse -doCall url mc = - do +doCall :: String -> HeadersAList -> MethodCall -> Err IO MethodResponse +doCall url headers mc = + do let req = renderCall mc - --FIXME: remove - --putStrLn req - resp <- ioErrorToErr $ post url req - --FIXME: remove - --putStrLn resp - parseResponse resp + resp <- ioErrorToErr $ post url headers req + parseResponse (BSL.unpack resp) -- | Low-level method calling function. Use this function if --- you need to do custom conversions between XML-RPC types and +-- you need to do custom conversions between XML-RPC types and -- Haskell types. -- Throws an exception if the response was a fault. call :: String -- ^ URL for the XML-RPC server. -> String -- ^ Method name. -> [Value] -- ^ The arguments. -> Err IO Value -- ^ The result -call url method args = doCall url (MethodCall method args) >>= handleResponse +call url method args = doCall url [] (MethodCall method args) >>= handleResponse +-- | Low-level method calling function. Use this function if +-- you need to do custom conversions between XML-RPC types and +-- Haskell types. Takes a list of extra headers to add to the +-- HTTP request. +-- Throws an exception if the response was a fault. +callWithHeaders :: String -- ^ URL for the XML-RPC server. + -> String -- ^ Method name. + -> HeadersAList -- ^ Extra headers to add to HTTP request. + -> [Value] -- ^ The arguments. + -> Err IO Value -- ^ The result +callWithHeaders url method headers args = + doCall url headers (MethodCall method args) >>= handleResponse + -- | Call a remote method. -remote :: Remote a => - String -- ^ Server URL. May contain username and password on - -- the format username:password\@ before the hostname. +remote :: Remote a => + String -- ^ Server URL. May contain username and password on + -- the format username:password\@ before the hostname. -> String -- ^ Remote method name. - -> a -- ^ Any function - -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => + -> a -- ^ Any function + -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m) +-- | Call a remote method. Takes a list of extra headers to add to the HTTP +-- request. +remoteWithHeaders :: Remote a => + String -- ^ Server URL. May contain username and password on + -- the format username:password\@ before the hostname. + -> String -- ^ Remote method name. + -> HeadersAList -- ^ Extra headers to add to HTTP request. + -> a -- ^ Any function + -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => + -- t1 -> ... -> tn -> IO r@ +remoteWithHeaders u m headers = + remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) + (callWithHeaders u m headers) + class Remote a where remote_ :: (String -> String) -- ^ Will be applied to all error - -- messages. - -> ([Value] -> Err IO Value) - -> a + -- messages. + -> ([Value] -> Err IO Value) + -> a instance XmlRpcType a => Remote (IO a) where remote_ h f = handleError (fail . h) $ f [] >>= fromValue @@ -110,72 +149,88 @@ -- HTTP functions -- -userAgent :: String +userAgent :: BS.ByteString userAgent = "Haskell XmlRpcClient/0.1" --- | Handle connection errors. -handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a -handleE h (Left e) = h e -handleE _ (Right v) = return v - -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail? -post :: String -> ByteString -> IO String -post url content = do + +post :: String -> HeadersAList -> BSL.ByteString -> IO U.ByteString +post url headers content = do uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url) - let a = authority uri - auth <- maybeFail ("Bad URI authority: '" ++ a ++ "'") (parseURIAuthority a) - post_ uri auth content + let a = uriAuthority uri + auth <- maybeFail ("Bad URI authority: '" ++ show (fmap showAuth a) ++ "'") a + post_ uri auth headers content + where showAuth (URIAuth u r p) = "URIAuth "++u++" "++r++" "++p -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail? -post_ :: URI -> URIAuthority -> ByteString -> IO String -post_ uri auth content = - do - -- FIXME: remove - --putStrLn (show (request uri content)) - --putStrLn content - eresp <- simpleHTTP (request uri auth (BS.concat . toChunks $ content)) - resp <- handleE (fail . show) eresp - case rspCode resp of - (2,0,0) -> return (U.toString (rspBody resp)) - _ -> fail (httpError resp) - where - showRspCode (a,b,c) = map intToDigit [a,b,c] - httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp +post_ :: URI -> URIAuth -> HeadersAList -> BSL.ByteString -> IO U.ByteString +post_ uri auth headers content = withOpenSSL $ do + let hostname = BS.pack (uriRegName auth) + port base = fromMaybe base (readMaybe $ drop 1 $ uriPort auth) + c <- case init $ uriScheme uri of + "http" -> + openConnection hostname (port 80) + "https" -> do + ctx <- baselineContextSSL + openConnectionSSL ctx hostname (port 443) + x -> fail ("Unknown scheme: '" ++ x ++ "'!") + + req <- request uri auth headers (BSL.length content) + body <- inputStreamBody <$> Streams.fromLazyByteString content + + _ <- sendRequest c req body + + s <- receiveResponse c $ \resp i -> do + case getStatusCode resp of + 200 -> readLazyByteString i + _ -> fail (show (getStatusCode resp) ++ " " ++ BS.unpack (getStatusMessage resp)) + + closeConnection c + + return s + +readLazyByteString :: Streams.InputStream BS.ByteString -> IO U.ByteString +readLazyByteString i = BSL.fromChunks <$> go + where + go :: IO [BS.ByteString] + go = do + res <- Streams.read i + case res of + Nothing -> return [] + Just bs -> (bs:) <$> go + -- | Create an XML-RPC compliant HTTP request. -request :: URI -> URIAuthority -> BS.ByteString -> Request BS.ByteString -request uri auth content = Request{ rqURI = uri, - rqMethod = POST, - rqHeaders = headers, - rqBody = content } - where - -- the HTTP module adds a Host header based on the URI - headers = [Header HdrUserAgent userAgent, - Header HdrContentType "text/xml", - Header HdrContentLength (show (BS.length content)) - ] ++ maybeToList (authHdr (user auth) (password auth)) +request :: URI -> URIAuth -> [(BS.ByteString, BS.ByteString)] -> Int64 -> IO Request +request uri auth usrHeaders len = buildRequest $ do + http POST (BS.pack $ uriPath uri) + setContentType "text/xml" + setContentLength len + setAccept "application/xml" --- | Creates an Authorization header using the Basic scheme, --- see RFC 2617 section 2. -authHdr :: Maybe String -- ^ User name, if any - -> Maybe String -- ^ Password, if any - -> Maybe Header -- ^ If user name or password was given, returns - -- an Authorization header, otherwise 'Nothing' -authHdr Nothing Nothing = Nothing -authHdr u p = Just (Header HdrAuthorization ("Basic " ++ base64encode user_pass)) - where user_pass = fromMaybe "" u ++ ":" ++ fromMaybe "" p - base64encode = Base64.encode . stringToOctets - -- FIXME: this probably only works right for latin-1 strings - stringToOctets :: String -> [Word8] - stringToOctets = map (fromIntegral . fromEnum) + case parseUserInfo auth of + (Just user, Just pass) -> setAuthorizationBasic (BS.pack user) (BS.pack pass) + _ -> return () + mapM_ (uncurry setHeader) usrHeaders + + setHeader "User-Agent" userAgent + + where + parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info + in ( if null u then Nothing else Just u + , (dropAtEnd . snd) <$> uncons pw ) + -- -- Utility functions -- -maybeFail :: Monad m => String -> Maybe a -> m a -maybeFail msg = maybe (fail msg) return +maybeFail :: MonadFail m => String -> Maybe a -> m a +maybeFail msg = maybe (Fail.fail msg) return + +dropAtEnd :: String -> String +dropAtEnd l = take (length l - 1) l 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,27 +1,31 @@ module Network.XmlRpc.DTD_XMLRPC where -import Text.XML.HaXml.XmlContent -import Text.XML.HaXml.OneOfN +import Text.XML.HaXml.OneOfN +import Text.XML.HaXml.Types (QName (..)) +import Text.XML.HaXml.XmlContent {-Type decls-} -newtype I4 = I4 String deriving (Eq,Show) -newtype AInt = AInt String deriving (Eq,Show) -newtype Boolean = Boolean String deriving (Eq,Show) -newtype AString = AString String deriving (Eq,Show) -newtype ADouble = ADouble String deriving (Eq,Show) -newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show) -newtype Base64 = Base64 String deriving (Eq,Show) -newtype Data = Data [Value] deriving (Eq,Show) -newtype Array = Array Data deriving (Eq,Show) -newtype Name = Name String deriving (Eq,Show) +newtype I4 = I4 String deriving (Eq,Show) +newtype I8 = I8 String deriving (Eq,Show) +newtype AInt = AInt String deriving (Eq,Show) +newtype Boolean = Boolean String deriving (Eq,Show) +newtype AString = AString String deriving (Eq,Show) +newtype ADouble = ADouble String deriving (Eq,Show) +newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show) +newtype Base64 = Base64 String deriving (Eq,Show) +newtype Data = Data [Value] deriving (Eq,Show) +newtype Array = Array Data deriving (Eq,Show) +newtype Name = Name String deriving (Eq,Show) data Member = Member Name Value deriving (Eq,Show) -newtype Struct = Struct [Member] deriving (Eq,Show) -newtype Value = Value [Value_] deriving (Eq,Show) +newtype Struct = Struct [Member] deriving (Eq,Show) +newtype Nil = Nil () deriving (Eq,Show) +newtype Value = Value [Value_] deriving (Eq,Show) data Value_ = Value_Str String | Value_I4 I4 + | Value_I8 I8 | Value_AInt AInt | Value_Boolean Boolean | Value_AString AString @@ -30,13 +34,14 @@ | Value_Base64 Base64 | Value_Struct Struct | Value_Array Array + | Value_Nil Nil deriving (Eq,Show) -newtype Param = Param Value deriving (Eq,Show) -newtype Params = Params [Param] deriving (Eq,Show) -newtype MethodName = MethodName String deriving (Eq,Show) +newtype Param = Param Value deriving (Eq,Show) +newtype Params = Params [Param] deriving (Eq,Show) +newtype MethodName = MethodName String deriving (Eq,Show) data MethodCall = MethodCall MethodName (Maybe Params) deriving (Eq,Show) -newtype Fault = Fault Value deriving (Eq,Show) +newtype Fault = Fault Value deriving (Eq,Show) data MethodResponse = MethodResponseParams Params | MethodResponseFault Fault deriving (Eq,Show) @@ -48,17 +53,27 @@ toHType x = Defined "i4" [] [] instance XmlContent I4 where toContents (I4 a) = - [CElem (Elem "i4" [] (toText a)) ()] + [CElem (Elem (N "i4") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["i4"] ; interior e $ return (I4) `apply` (text `onFail` return "") } `adjustErr` ("in , "++) +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 "int" [] (toText a)) ()] + [CElem (Elem (N "int") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["int"] ; interior e $ return (AInt) `apply` (text `onFail` return "") @@ -68,7 +83,7 @@ toHType x = Defined "boolean" [] [] instance XmlContent Boolean where toContents (Boolean a) = - [CElem (Elem "boolean" [] (toText a)) ()] + [CElem (Elem (N "boolean") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["boolean"] ; interior e $ return (Boolean) `apply` (text `onFail` return "") @@ -78,7 +93,7 @@ toHType x = Defined "string" [] [] instance XmlContent AString where toContents (AString a) = - [CElem (Elem "string" [] (toText a)) ()] + [CElem (Elem (N "string") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["string"] ; interior e $ return (AString) `apply` (text `onFail` return "") @@ -88,7 +103,7 @@ toHType x = Defined "double" [] [] instance XmlContent ADouble where toContents (ADouble a) = - [CElem (Elem "double" [] (toText a)) ()] + [CElem (Elem (N "double") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["double"] ; interior e $ return (ADouble) `apply` (text `onFail` return "") @@ -98,18 +113,28 @@ toHType x = Defined "dateTime.iso8601" [] [] instance XmlContent DateTime_iso8601 where toContents (DateTime_iso8601 a) = - [CElem (Elem "dateTime.iso8601" [] (toText a)) ()] + [CElem (Elem (N "dateTime.iso8601") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["dateTime.iso8601"] ; interior e $ return (DateTime_iso8601) `apply` (text `onFail` return "") } `adjustErr` ("in , "++) +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 "base64" [] (toText a)) ()] + [CElem (Elem (N "base64") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["base64"] ; interior e $ return (Base64) `apply` (text `onFail` return "") @@ -119,7 +144,7 @@ toHType x = Defined "data" [] [] instance XmlContent Data where toContents (Data a) = - [CElem (Elem "data" [] (concatMap toContents a)) ()] + [CElem (Elem (N "data") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["data"] ; interior e $ return (Data) `apply` many parseContents @@ -129,7 +154,7 @@ toHType x = Defined "array" [] [] instance XmlContent Array where toContents (Array a) = - [CElem (Elem "array" [] (toContents a)) ()] + [CElem (Elem (N "array") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["array"] ; interior e $ return (Array) `apply` parseContents @@ -139,7 +164,7 @@ toHType x = Defined "name" [] [] instance XmlContent Name where toContents (Name a) = - [CElem (Elem "name" [] (toText a)) ()] + [CElem (Elem (N "name") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["name"] ; interior e $ return (Name) `apply` (text `onFail` return "") @@ -149,7 +174,7 @@ toHType x = Defined "member" [] [] instance XmlContent Member where toContents (Member a b) = - [CElem (Elem "member" [] (toContents a ++ toContents b)) ()] + [CElem (Elem (N "member") [] (toContents a ++ toContents b)) ()] parseContents = do { e@(Elem _ [] _) <- element ["member"] ; interior e $ return (Member) `apply` parseContents @@ -160,7 +185,7 @@ toHType x = Defined "struct" [] [] instance XmlContent Struct where toContents (Struct a) = - [CElem (Elem "struct" [] (concatMap toContents a)) ()] + [CElem (Elem (N "struct") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["struct"] ; interior e $ return (Struct) `apply` many parseContents @@ -170,7 +195,7 @@ toHType x = Defined "value" [] [] instance XmlContent Value where toContents (Value a) = - [CElem (Elem "value" [] (concatMap toContents a)) ()] + [CElem (Elem (N "value") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["value"] ; interior e $ return (Value) `apply` many parseContents @@ -181,6 +206,7 @@ instance XmlContent Value_ where toContents (Value_Str a) = toText a toContents (Value_I4 a) = toContents a + toContents (Value_I8 a) = toContents a toContents (Value_AInt a) = toContents a toContents (Value_Boolean a) = toContents a toContents (Value_AString a) = toContents a @@ -189,9 +215,11 @@ toContents (Value_Base64 a) = toContents a toContents (Value_Struct a) = toContents a toContents (Value_Array a) = toContents a + toContents (Value_Nil a) = toContents a parseContents = oneOf [ return (Value_Str) `apply` text , return (Value_I4) `apply` parseContents + , return (Value_I8) `apply` parseContents , return (Value_AInt) `apply` parseContents , return (Value_Boolean) `apply` parseContents , return (Value_AString) `apply` parseContents @@ -200,13 +228,14 @@ , return (Value_Base64) `apply` parseContents , return (Value_Struct) `apply` parseContents , return (Value_Array) `apply` parseContents + , return (Value_Nil) `apply` parseContents ] `adjustErr` ("in , "++) instance HTypeable Param where toHType x = Defined "param" [] [] instance XmlContent Param where toContents (Param a) = - [CElem (Elem "param" [] (toContents a)) ()] + [CElem (Elem (N "param") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["param"] ; interior e $ return (Param) `apply` parseContents @@ -216,7 +245,7 @@ toHType x = Defined "params" [] [] instance XmlContent Params where toContents (Params a) = - [CElem (Elem "params" [] (concatMap toContents a)) ()] + [CElem (Elem (N "params") [] (concatMap toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["params"] ; interior e $ return (Params) `apply` many parseContents @@ -226,7 +255,7 @@ toHType x = Defined "methodName" [] [] instance XmlContent MethodName where toContents (MethodName a) = - [CElem (Elem "methodName" [] (toText a)) ()] + [CElem (Elem (N "methodName") [] (toText a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["methodName"] ; interior e $ return (MethodName) @@ -237,7 +266,7 @@ toHType x = Defined "methodCall" [] [] instance XmlContent MethodCall where toContents (MethodCall a b) = - [CElem (Elem "methodCall" [] (toContents a ++ + [CElem (Elem (N "methodCall") [] (toContents a ++ maybe [] toContents b)) ()] parseContents = do { e@(Elem _ [] _) <- element ["methodCall"] @@ -249,7 +278,7 @@ toHType x = Defined "fault" [] [] instance XmlContent Fault where toContents (Fault a) = - [CElem (Elem "fault" [] (toContents a)) ()] + [CElem (Elem (N "fault") [] (toContents a)) ()] parseContents = do { e@(Elem _ [] _) <- element ["fault"] ; interior e $ return (Fault) `apply` parseContents @@ -259,10 +288,10 @@ toHType x = Defined "methodResponse" [] [] instance XmlContent MethodResponse where toContents (MethodResponseParams a) = - [CElem (Elem "methodResponse" [] (toContents a) ) ()] + [CElem (Elem (N "methodResponse") [] (toContents a) ) ()] toContents (MethodResponseFault a) = - [CElem (Elem "methodResponse" [] (toContents a) ) ()] - parseContents = do + [CElem (Elem (N "methodResponse") [] (toContents a) ) ()] + parseContents = do { e@(Elem _ [] _) <- element ["methodResponse"] ; interior e $ oneOf [ return (MethodResponseParams) `apply` parseContents 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.XmlContent -import Network.XmlRpc.Pretty -import Data.ByteString.Lazy.Char8 (ByteString, pack) +#if ! MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) +#endif + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack) +import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, pack) import qualified Network.XmlRpc.Base64 as Base64 import qualified Network.XmlRpc.DTD_XMLRPC as XR +import Network.XmlRpc.Pretty +import Text.XML.HaXml.XmlContent -- -- General utilities @@ -61,11 +85,11 @@ -- | Replaces all occurances of a sublist in a list with another list. -- If the list to replace is the empty list, does nothing. -replace :: Eq a => - [a] -- ^ The sublist to replace when found - -> [a] -- ^ The list to replace it with - -> [a] -- ^ The list to replace in - -> [a] -- ^ The result +replace :: Eq a => + [a] -- ^ The sublist to replace when found + -> [a] -- ^ The list to replace it with + -> [a] -- ^ The list to replace in + -> [a] -- ^ The result replace [] _ xs = xs replace _ _ [] = [] replace ys zs xs@(x:xs') @@ -73,29 +97,30 @@ | otherwise = x : replace ys zs xs' -- | Convert a 'Maybe' value to a value in any monad -maybeToM :: Monad m => - String -- ^ Error message to fail with for 'Nothing' - -> Maybe a -- ^ The 'Maybe' value. - -> m a -- ^ The resulting value in the monad. -maybeToM err Nothing = fail err +maybeToM :: MonadFail m => + String -- ^ Error message to fail with for 'Nothing' + -> Maybe a -- ^ The 'Maybe' value. + -> m a -- ^ The resulting value in the monad. +maybeToM err Nothing = Fail.fail err maybeToM _ (Just x) = return x -- | Convert a 'Maybe' value to a value in any monad -eitherToM :: Monad m +eitherToM :: MonadFail m => String -- ^ Error message to fail with for 'Nothing' - -> Either String a -- ^ The 'Maybe' value. - -> m a -- ^ The resulting value in the monad. -eitherToM err (Left s) = fail (err ++ ": " ++ s) + -> Either String a -- ^ The 'Maybe' value. + -> m a -- ^ The resulting value in the monad. +eitherToM err (Left s) = Fail.fail (err ++ ": " ++ s) eitherToM _ (Right x) = return x -- | The format for \"dateTime.iso8601\" +xmlRpcDateFormat :: String xmlRpcDateFormat = "%Y%m%dT%H:%M:%S" -- -- Error monad stuff -- -type Err m a = ErrorT String m a +type Err m a = ExceptT String m a -- | Evaluate the argument and catch error call exceptions errorToErr :: (Show e, MonadError e m) => a -> Err m a @@ -108,68 +133,60 @@ ioErrorToErr x = (liftIO x >>= return) `catchError` \e -> throwError (show e) -- | Handle errors from the error monad. -handleError :: Monad m => (String -> m a) -> Err m a -> m a -handleError h m = do - Right x <- runErrorT (catchError m (lift . h)) - return x +handleError :: MonadFail m => (String -> m a) -> Err m a -> m a +handleError h m = do + Right x <- runExceptT (catchError m (lift . h)) + return x -errorRead :: (Monad m, Read a) => - ReadS a -- ^ Parser - -> String -- ^ Error message - -> String -- ^ String to parse - -> Err m a +errorRead :: (MonadFail m, Read a) => + ReadS a -- ^ Parser + -> String -- ^ Error message + -> String -- ^ String to parse + -> Err m a errorRead r err s = case [x | (x,t) <- r s, ("","") <- lex t] of - [x] -> return x - _ -> fail (err ++ ": '" ++ s ++ "'") - --- | Convert an 'Int' to some instance of 'Enum', and fail if the --- 'Int' is out of range. -errorToEnum :: (Monad m, Bounded a, Enum a) => - String -- ^ Error message - -> Int - -> Err m a -errorToEnum err x | x < fromEnum (minBound `asTypeOf` r) = fail err - | x > fromEnum (maxBound `asTypeOf` r) = fail err - | otherwise = return r - where r = toEnum x + [x] -> return x + _ -> Fail.fail (err ++ ": '" ++ s ++ "'") -- -- Types for methods calls and responses -- --- | An XML-RPC method call. Consists of a method name and a list of +-- | An XML-RPC method call. Consists of a method name and a list of -- parameters. data MethodCall = MethodCall String [Value] - deriving (Eq, Show) -- for debugging + deriving (Eq, Show) -- for debugging -- | An XML-RPC response. data MethodResponse = Return Value -- ^ A method response returning a value - | Fault Int String -- ^ A fault response - deriving (Eq, Show) -- for debugging + | Fault Int String -- ^ A fault response + deriving (Eq, Show) -- for debugging -- | An XML-RPC value. -data Value = - ValueInt Int -- ^ int or i4 +data Value = + ValueInt Int -- ^ int, i4, or i8 | ValueBool Bool -- ^ bool | ValueString String -- ^ string + | ValueUnwrapped String -- ^ no inner element | ValueDouble Double -- ^ double | ValueDateTime LocalTime -- ^ dateTime.iso8601 - | ValueBase64 String -- ^ base 64 + | ValueBase64 BS.ByteString -- ^ base 64. NOTE that you should provide the raw data; the haxr library takes care of doing the base-64 encoding. | ValueStruct [(String,Value)] -- ^ struct | ValueArray [Value] -- ^ array - deriving (Eq, Show) -- for debugging + | ValueNil -- ^ nil + deriving (Eq, Show) -- for debugging -- | An XML-RPC value. Use for error messages and introspection. -data Type = - TInt - | TBool - | TString - | TDouble - | TDateTime - | TBase64 - | TStruct - | TArray - | TUnknown +data Type = + TInt + | TBool + | TString + | TDouble + | TDateTime + | TBase64 + | TStruct + | TArray + | TUnknown + | TNil deriving (Eq) instance Show Type where @@ -182,37 +199,39 @@ show TStruct = "struct" show TArray = "array" show TUnknown = "unknown" + show TNil = "nil" instance Read Type where readsPrec _ s = case break isSpace (dropWhile isSpace s) of - ("int",r) -> [(TInt,r)] - ("bool",r) -> [(TBool,r)] - ("string",r) -> [(TString,r)] - ("double",r) -> [(TDouble,r)] - ("dateTime.iso8601",r) -> [(TDateTime,r)] - ("base64",r) -> [(TBase64,r)] - ("struct",r) -> [(TStruct,r)] - ("array",r) -> [(TArray,r)] + ("int",r) -> [(TInt,r)] + ("bool",r) -> [(TBool,r)] + ("string",r) -> [(TString,r)] + ("double",r) -> [(TDouble,r)] + ("dateTime.iso8601",r) -> [(TDateTime,r)] + ("base64",r) -> [(TBase64,r)] + ("struct",r) -> [(TStruct,r)] + ("array",r) -> [(TArray,r)] + ("nil",r) -> [(TNil,r)] -- | Gets the value of a struct member -structGetValue :: Monad m => String -> Value -> Err m Value -structGetValue n (ValueStruct t) = +structGetValue :: MonadFail m => String -> Value -> Err m Value +structGetValue n (ValueStruct t) = maybeToM ("Unknown member '" ++ n ++ "'") (lookup n t) structGetValue _ _ = fail "Value is not a struct" --- | Builds a fault struct +-- | Builds a fault struct faultStruct :: Int -> String -> Value faultStruct code str = ValueStruct [("faultCode",ValueInt code), - ("faultString",ValueString str)] + ("faultString",ValueString str)] -- XML-RPC specification: -- "The body of the response is a single XML structure, a -- , 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 False (toXRValue v) ++ "'") `asTypeOf` return t + Fail.fail ("Wanted: " + ++ show (getType t) + ++ "', got: '" + ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t -- a type hack for use in 'typeError' withType :: (a -> Err m a) -> Err m a withType f = f undefined -simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a) - -> Value -> Err m a -simpleFromValue f v = +simpleFromValue :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a) + -> Value -> Err m a +simpleFromValue f v = maybe (typeError v) return (f v) @@ -256,37 +275,49 @@ instance XmlRpcType Int where toValue = ValueInt fromValue = simpleFromValue f - where f (ValueInt x) = Just x - f _ = Nothing + where f (ValueInt x) = Just x + f _ = Nothing getType _ = TInt instance XmlRpcType Bool where toValue = ValueBool fromValue = simpleFromValue f - where f (ValueBool x) = Just x - f _ = Nothing + where f (ValueBool x) = Just x + f _ = Nothing getType _ = TBool -instance XmlRpcType String where +instance OVERLAPPING_ XmlRpcType String where toValue = ValueString fromValue = simpleFromValue f - where f (ValueString x) = Just x - f (ValueBase64 x) = Just x - f _ = Nothing + where f (ValueString x) = Just x + f (ValueUnwrapped x) = Just x + f _ = Nothing getType _ = TString +instance XmlRpcType Text where + toValue = ValueString . T.unpack + fromValue = (liftM T.pack) . fromValue + getType _ = TString + +instance XmlRpcType BS.ByteString where + toValue = ValueBase64 + fromValue = simpleFromValue f + where f (ValueBase64 x) = Just x + f _ = Nothing + getType _ = TBase64 + instance XmlRpcType Double where toValue = ValueDouble fromValue = simpleFromValue f - where f (ValueDouble x) = Just x - f _ = Nothing + where f (ValueDouble x) = Just x + f _ = Nothing getType _ = TDouble instance XmlRpcType LocalTime where toValue = ValueDateTime fromValue = simpleFromValue f - where f (ValueDateTime x) = Just x - f _ = Nothing + where f (ValueDateTime x) = Just x + f _ = Nothing getType _ = TDateTime instance XmlRpcType CalendarTime where @@ -294,46 +325,53 @@ fromValue = liftM localTimeToCalendarTime . fromValue getType _ = TDateTime +instance XmlRpcType () where + toValue = const ValueNil + fromValue = simpleFromValue f + where f ValueNil = Just () + f _ = Nothing + getType _ = TNil + -- FIXME: array elements may have different types -instance XmlRpcType a => XmlRpcType [a] where - toValue = ValueArray . map toValue +instance OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where + toValue = ValueArray . map toValue fromValue v = case v of - ValueArray xs -> mapM fromValue xs - _ -> typeError v + ValueArray xs -> mapM fromValue xs + _ -> typeError v getType _ = TArray -- FIXME: struct elements may have different types -instance XmlRpcType a => XmlRpcType [(String,a)] where +instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs] fromValue v = case v of - ValueStruct xs -> mapM (\ (n,v) -> liftM ((,) n) (fromValue v)) xs - _ -> typeError v + ValueStruct xs -> mapM (\ (n,v') -> liftM ((,) n) (fromValue v')) xs + _ -> typeError v getType _ = TStruct -- Tuple instances may be used for heterogenous array types. -instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d, - XmlRpcType e) => +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d, + XmlRpcType e) => XmlRpcType (a,b,c,d,e) where - toValue (v,w,x,y,z) = + toValue (v,w,x,y,z) = ValueArray [toValue v, toValue w, toValue x, toValue y, toValue z] - fromValue (ValueArray [v,w,x,y,z]) = - liftM5 (,,,,) (fromValue v) (fromValue w) (fromValue x) - (fromValue y) (fromValue z) + fromValue (ValueArray [v,w,x,y,z]) = + liftM5 (,,,,) (fromValue v) (fromValue w) (fromValue x) + (fromValue y) (fromValue z) fromValue _ = throwError "Expected 5-element tuple!" getType _ = TArray -instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) => +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) => XmlRpcType (a,b,c,d) where toValue (w,x,y,z) = ValueArray [toValue w, toValue x, toValue y, toValue z] - fromValue (ValueArray [w,x,y,z]) = + fromValue (ValueArray [w,x,y,z]) = liftM4 (,,,) (fromValue w) (fromValue x) (fromValue y) (fromValue z) fromValue _ = throwError "Expected 4-element tuple!" getType _ = TArray instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where toValue (x,y,z) = ValueArray [toValue x, toValue y, toValue z] - fromValue (ValueArray [x,y,z]) = + fromValue (ValueArray [x,y,z]) = liftM3 (,,) (fromValue x) (fromValue y) (fromValue z) fromValue _ = throwError "Expected 3-element tuple!" getType _ = TArray @@ -345,21 +383,21 @@ getType _ = TArray -- | Get a field value from a (possibly heterogeneous) struct. -getField :: (Monad m, XmlRpcType a) => - String -- ^ Field name - -> [(String,Value)] -- ^ Struct - -> Err m a -getField x xs = maybeToM ("struct member " ++ show x ++ " not found") - (lookup x xs) >>= fromValue +getField :: (MonadFail m, XmlRpcType a) => + String -- ^ Field name + -> [(String,Value)] -- ^ Struct + -> Err m a +getField x xs = maybeToM ("struct member " ++ show x ++ " not found") + (lookup x xs) >>= fromValue -- | Get a field value from a (possibly heterogeneous) struct. -getFieldMaybe :: (Monad m, XmlRpcType a) => - String -- ^ Field name - -> [(String,Value)] -- ^ Struct - -> Err m (Maybe a) -getFieldMaybe x xs = case lookup x xs of - Nothing -> return Nothing - Just v -> liftM Just (fromValue v) +getFieldMaybe :: (MonadFail m, XmlRpcType a) => + String -- ^ Field name + -> [(String,Value)] -- ^ Struct + -> Err m (Maybe a) +getFieldMaybe x xs = case lookup x xs of + Nothing -> return Nothing + Just v -> liftM Just (fromValue v) -- -- Converting to XR types @@ -369,13 +407,15 @@ toXRValue (ValueInt x) = XR.Value [XR.Value_AInt (XR.AInt (showInt x))] toXRValue (ValueBool b) = XR.Value [XR.Value_Boolean (XR.Boolean (showBool b))] toXRValue (ValueString s) = XR.Value [XR.Value_AString (XR.AString (showString s))] +toXRValue (ValueUnwrapped s) = XR.Value [XR.Value_Str s] toXRValue (ValueDouble d) = XR.Value [XR.Value_ADouble (XR.ADouble (showDouble d))] -toXRValue (ValueDateTime t) = +toXRValue (ValueDateTime t) = XR.Value [ XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 (showDateTime t))] toXRValue (ValueBase64 s) = XR.Value [XR.Value_Base64 (XR.Base64 (showBase64 s))] toXRValue (ValueStruct xs) = XR.Value [XR.Value_Struct (XR.Struct (map toXRMember xs))] -toXRValue (ValueArray xs) = +toXRValue (ValueArray xs) = XR.Value [XR.Value_Array (XR.Array (XR.Data (map toXRValue xs)))] +toXRValue ValueNil = XR.Value [XR.Value_Nil (XR.Nil ())] showInt :: Int -> String showInt = show @@ -383,9 +423,9 @@ showBool :: Bool -> String showBool b = if b then "1" else "0" --- escapes & and < +-- escapes &, <, and < showString :: String -> String -showString s = replace "<" "<" (replace "&" "&" s) +showString = replace ">" ">" . replace "<" "<" . replace "&" "&" -- | Shows a double in signed decimal point notation. showDouble :: Double -> String @@ -395,24 +435,19 @@ showDateTime :: LocalTime -> String showDateTime t = formatTime defaultTimeLocale xmlRpcDateFormat t -showBase64 :: String -> String -showBase64 = Base64.encode . stringToOctets - where - -- FIXME: this probably only works right for latin-1 strings - stringToOctets :: String -> [Word8] - stringToOctets = map (fromIntegral . fromEnum) - +showBase64 :: BS.ByteString -> String +showBase64 = BS.unpack . Base64.encode toXRMethodCall :: MethodCall -> XR.MethodCall -toXRMethodCall (MethodCall name vs) = +toXRMethodCall (MethodCall name vs) = XR.MethodCall (XR.MethodName name) (Just (toXRParams vs)) toXRMethodResponse :: MethodResponse -> XR.MethodResponse toXRMethodResponse (Return val) = XR.MethodResponseParams (toXRParams [val]) -toXRMethodResponse (Fault code str) = +toXRMethodResponse (Fault code str) = XR.MethodResponseFault (XR.Fault (toXRValue (faultStruct code str))) -toXRParams :: [Value] -> XR.Params +toXRParams :: [Value] -> XR.Params toXRParams vs = XR.Params (map (XR.Param . toXRValue) vs) toXRMember :: (String, Value) -> XR.Member @@ -422,10 +457,10 @@ -- Converting from XR types -- -fromXRValue :: Monad m => XR.Value -> Err m Value +fromXRValue :: MonadFail m => XR.Value -> Err m Value fromXRValue (XR.Value vs) = case (filter notstr vs) of - [] -> liftM (ValueString . concat) (mapM (readString . unstr) vs) + [] -> liftM (ValueUnwrapped . concat) (mapM (readString . unstr) vs) (v:_) -> f v where notstr (XR.Value_Str _) = False @@ -434,6 +469,7 @@ unstr (XR.Value_Str x) = x f (XR.Value_I4 (XR.I4 x)) = liftM ValueInt (readInt x) + f (XR.Value_I8 (XR.I8 x)) = liftM ValueInt (readInt x) f (XR.Value_AInt (XR.AInt x)) = liftM ValueInt (readInt x) f (XR.Value_Boolean (XR.Boolean x)) = liftM ValueBool (readBool x) f (XR.Value_ADouble (XR.ADouble x)) = liftM ValueDouble (readDouble x) @@ -441,13 +477,14 @@ f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 x)) = liftM ValueDateTime (readDateTime x) f (XR.Value_Base64 (XR.Base64 x)) = liftM ValueBase64 (readBase64 x) - f (XR.Value_Struct (XR.Struct ms)) = - liftM ValueStruct (mapM fromXRMember ms) - f (XR.Value_Array (XR.Array (XR.Data xs))) = - liftM ValueArray (mapM fromXRValue xs) + f (XR.Value_Struct (XR.Struct ms)) = + liftM ValueStruct (mapM fromXRMember ms) + f (XR.Value_Array (XR.Array (XR.Data xs))) = + liftM ValueArray (mapM fromXRValue xs) + f (XR.Value_Nil (XR.Nil x)) = return ValueNil -fromXRMember :: Monad m => XR.Member -> Err m (String,Value) +fromXRMember :: MonadFail m => XR.Member -> Err m (String,Value) fromXRMember (XR.Member (XR.Name n) xv) = liftM (\v -> (n,v)) (fromXRValue xv) -- | From the XML-RPC specification: @@ -456,36 +493,36 @@ -- minus at the beginning of a string of numeric characters. Leading -- zeros are collapsed. Whitespace is not permitted. Just numeric -- characters preceeded by a plus or minus.\" -readInt :: Monad m => String -> Err m Int +readInt :: MonadFail m => String -> Err m Int readInt s = errorRead reads "Error parsing integer" s -- | From the XML-RPC specification: -- -- \"0 (false) or 1 (true)\" -readBool :: Monad m => String -> Err m Bool +readBool :: MonadFail m => String -> Err m Bool readBool s = errorRead readsBool "Error parsing boolean" s where readsBool "true" = [(True,"")] - readsBool "false" = [(False,"")] - readsBool "1" = [(True,"")] - readsBool "0" = [(False,"")] - readsBool _ = [] + readsBool "false" = [(False,"")] + readsBool "1" = [(True,"")] + readsBool "0" = [(False,"")] + readsBool _ = [] -- | From the XML-RPC specification: -- -- \"Any characters are allowed in a string except \< and &, which are -- encoded as < and &. A string can be used to encode binary data.\" -- --- To work with implementations (such as some Python bindings for example) +-- To work with implementations (such as some Python bindings for example) -- which also escape \>, > is unescaped. This is non-standard, but -- seems unlikely to cause problems. readString :: Monad m => String -> Err m String readString = return . replace "&" "&" . replace "<" "<" - . replace ">" ">" + . replace ">" ">" -- | From the XML-RPC specification: --- +-- -- There is no representation for infinity or negative infinity or \"not -- a number\". At this time, only decimal point notation is allowed, a -- plus or a minus, followed by any number of numeric characters, @@ -494,7 +531,7 @@ -- is implementation-dependent, is not specified. -- -- FIXME: accepts more than decimal point notation -readDouble :: Monad m => String -> Err m Double +readDouble :: MonadFail m => String -> Err m Double readDouble s = errorRead reads "Error parsing double" s -- | From : @@ -503,61 +540,56 @@ -- content of this element should not be assumed to comply with the -- variants of the ISO8601 standard. Only assume YYYYMMDDTHH:mm:SS\" -- FIXME: make more robust -readDateTime :: Monad m => String -> Err m LocalTime +readDateTime :: MonadFail m => String -> Err m LocalTime readDateTime dt = maybe - (fail $ "Error parsing dateTime '" ++ dt ++ "'") + (Fail.fail $ "Error parsing dateTime '" ++ dt ++ "'") return - (parseTime defaultTimeLocale xmlRpcDateFormat dt) + (parseTimeM True defaultTimeLocale xmlRpcDateFormat dt) localTimeToCalendarTime :: LocalTime -> CalendarTime -localTimeToCalendarTime l = +localTimeToCalendarTime l = let (y,mo,d) = toGregorian (localDay l) TimeOfDay { todHour = h, todMin = mi, todSec = s } = localTimeOfDay l (_,_,wd) = toWeekDate (localDay l) (_,yd) = toOrdinalDate (localDay l) in CalendarTime { - ctYear = fromIntegral y, - ctMonth = toEnum (mo-1), - ctDay = d, - ctHour = h, - ctMin = mi, - ctSec = truncate s, - ctPicosec = 0, - ctWDay = toEnum (wd `mod` 7), - ctYDay = yd, - ctTZName = "UTC", - ctTZ = 0, - ctIsDST = False - } + ctYear = fromIntegral y, + ctMonth = toEnum (mo-1), + ctDay = d, + ctHour = h, + ctMin = mi, + ctSec = truncate s, + ctPicosec = 0, + ctWDay = toEnum (wd `mod` 7), + ctYDay = yd, + ctTZName = "UTC", + ctTZ = 0, + ctIsDST = False + } calendarTimeToLocalTime :: CalendarTime -> LocalTime -calendarTimeToLocalTime ct = +calendarTimeToLocalTime ct = let (y,mo,d) = (ctYear ct, ctMonth ct, ctDay ct) (h,mi,s) = (ctHour ct, ctMin ct, ctSec ct) - in LocalTime { - localDay = fromGregorian (fromIntegral y) (fromEnum mo + 1) d, + in LocalTime { + localDay = fromGregorian (fromIntegral y) (fromEnum mo + 1) d, localTimeOfDay = TimeOfDay { todHour = h, todMin = mi, todSec = fromIntegral s } } -- FIXME: what if data contains non-base64 characters? -readBase64 :: Monad m => String -> Err m String -readBase64 = return . octetsToString . Base64.decode - where - -- FIXME: this probably only works right for latin-1 strings - octetsToString :: [Word8] -> String - octetsToString = map (toEnum . fromIntegral) - +readBase64 :: Monad m => String -> Err m BS.ByteString +readBase64 = return . Base64.decode . BS.pack -fromXRParams :: Monad m => XR.Params -> Err m [Value] +fromXRParams :: MonadFail m => XR.Params -> Err m [Value] fromXRParams (XR.Params xps) = mapM (\(XR.Param v) -> fromXRValue v) xps -fromXRMethodCall :: Monad m => XR.MethodCall -> Err m MethodCall -fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = +fromXRMethodCall :: MonadFail m => XR.MethodCall -> Err m MethodCall +fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = liftM (MethodCall name) (fromXRParams (fromMaybe (XR.Params []) params)) -fromXRMethodResponse :: Monad m => XR.MethodResponse -> Err m MethodResponse -fromXRMethodResponse (XR.MethodResponseParams xps) = +fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse +fromXRMethodResponse (XR.MethodResponseParams xps) = liftM Return (fromXRParams xps >>= onlyOneResult) fromXRMethodResponse (XR.MethodResponseFault (XR.Fault v)) = do @@ -570,19 +602,19 @@ -- -- Parsing calls and reponses from XML --- +-- -- | Parses a method call from XML. -parseCall :: (Show e, MonadError e m) => String -> Err m MethodCall -parseCall c = +parseCall :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodCall +parseCall c = do mxc <- errorToErr (readXml c) xc <- eitherToM "Error parsing method call" mxc fromXRMethodCall xc -- | Parses a method response from XML. -parseResponse :: (Show e, MonadError e m) => String -> Err m MethodResponse -parseResponse c = +parseResponse :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodResponse +parseResponse c = do mxr <- errorToErr (readXml c) xr <- eitherToM "Error parsing method response" mxr @@ -594,15 +626,15 @@ -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML -renderCall :: MethodCall -> ByteString +renderCall :: MethodCall -> BSL.ByteString renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML -renderResponse :: MethodResponse -> ByteString +renderResponse :: MethodResponse -> BSL.ByteString renderResponse = showXml' False . toXRMethodResponse -showXml' :: XmlContent a => Bool -> a -> ByteString +showXml' :: XmlContent a => Bool -> a -> BSL.ByteString showXml' dtd x = case toContents x of [CElem _ _] -> (document . toXml dtd) x - _ -> pack "" + _ -> BSL.pack "" 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 --- a/Network/XmlRpc/Pretty.hs +++ b/Network/XmlRpc/Pretty.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -- | This is a fast non-pretty-printer for turning the internal representation -- of generic structured XML documents into Lazy ByteStrings. @@ -6,26 +8,31 @@ -- Text.Xml.HaXml.Types, so you can pretty-print as much or as little -- of the document as you wish. -module Network.XmlRpc.Pretty (document, content, element, +module Network.XmlRpc.Pretty (document, content, element, doctypedecl, prolog, cp) where -import Prelude hiding (maybe, elem, concat, null, head) -import qualified Prelude as P -import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty) -import qualified Data.ByteString.Lazy.UTF8 as BU -import Text.XML.HaXml.Types -import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromString) -import Data.Maybe (isNothing) -import Data.Monoid -import qualified GHC.Exts as Ext +import Blaze.ByteString.Builder (Builder, + fromLazyByteString, + toLazyByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Data.ByteString.Lazy.Char8 (ByteString, elem, empty) +import qualified Data.ByteString.Lazy.UTF8 as BU +import Data.Maybe (isNothing) +import Data.Monoid (Monoid, mappend, mconcat, + mempty) +import Data.Semigroup (Semigroup) +import qualified GHC.Exts as Ext +import Prelude hiding (concat, elem, head, + maybe, null) +import qualified Prelude as P +import Text.XML.HaXml.Types -- |A 'Builder' with a recognizable empty value. -newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving Monoid +newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving (Semigroup, Monoid) -- |'Maybe' eliminator specialized for 'MBuilder'. maybe :: (t -> MBuilder) -> Maybe t -> MBuilder -maybe _ Nothing = mempty +maybe _ Nothing = mempty maybe f (Just x) = f x -- |Nullity predicate for 'MBuilder'. @@ -44,18 +51,22 @@ -- syntax. instance Ext.IsString MBuilder where fromString "" = mempty - fromString s = MBuilder . Just . fromString $ s + fromString s = MBuilder . Just . fromString $ s --- A simple implementation of the pretty-printing combinator interface, --- but for plain ByteStrings: +-- Only define <> as mappend if not already provided in Prelude +#if !MIN_VERSION_base(4,11,0) infixr 6 <> -infixr 6 <+> -infixr 5 $$ -- |Beside. (<>) :: MBuilder -> MBuilder -> MBuilder (<>) = mappend +#endif +-- A simple implementation of the pretty-printing combinator interface, +-- but for plain ByteStrings: +infixr 6 <+> +infixr 5 $$ + -- |Concatenate two 'MBuilder's with a single space in between -- them. If either of the component 'MBuilder's is empty, then the -- other is returned without any additional space. @@ -69,7 +80,7 @@ -- them. If either of the component 'MBuilder's is empty, then the -- other is returned without any additional newline. ($$) :: MBuilder -> MBuilder -> MBuilder -($$) b1 b2 +($$) b1 b2 | null b2 = b1 | null b1 = b2 | otherwise = b1 <> "\n" <> b2 @@ -82,7 +93,7 @@ aux (x:xs) = x <> mconcat (map (sep <>) xs) -- |List version of '<+>'. -hsep :: [MBuilder] -> MBuilder +hsep :: [MBuilder] -> MBuilder hsep = intercalate " " -- |List version of '$$'. @@ -96,7 +107,7 @@ vcatMap = (vcat .) . map -- |``Paragraph fill'' version of 'sep'. -fsep :: [MBuilder] -> MBuilder +fsep :: [MBuilder] -> MBuilder fsep = hsep -- |Bracket an 'MBuilder' with parentheses. @@ -106,6 +117,11 @@ text :: String -> MBuilder text = MBuilder . Just . fromString +name :: QName -> MBuilder +name = MBuilder . Just . fromString . unQ + where unQ (QN (Namespace prefix uri) n) = prefix++":"++n + unQ (N n) = n + ---- -- Now for the XML pretty-printing interface. -- (Basically copied direct from Text.XML.HaXml.Pretty). @@ -135,7 +151,7 @@ -- |Run an 'MBuilder' to generate a 'ByteString'. runMBuilder :: MBuilder -> ByteString runMBuilder = aux . unMB - where aux Nothing = empty + where aux Nothing = empty aux (Just b) = toLazyByteString b document = runMBuilder . documentB @@ -156,35 +172,35 @@ maybe encodingdecl e <+> maybe sddecl sd <+> "?>" -misc (Comment s) = "" -misc (PI (n,s)) = " text n <+> text s <+> "?>" +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 = " text n <+> maybe externalid eid + 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 +markupdecl (Element e) = elementdecl e +markupdecl (AttList a) = attlistdecl a +markupdecl (Entity e) = entitydecl e +markupdecl (Notation n) = notationdecl n +markupdecl (MarkupMisc m) = misc m -elementB (Elem n as []) = "<" <> (text n <+> fsep (map attribute as)) <> "/>" -elementB (Elem n as cs) - | isText (P.head cs) = "<" <> (text n <+> fsep (map attribute as)) <> ">" <> - hcatMap contentB cs <> " text n <> ">" - | otherwise = "<" <> (text n <+> fsep (map attribute as)) <> ">" <> - hcatMap contentB cs <> " text n <> ">" +elementB (Elem n as []) = "<" <> (name n <+> fsep (map attribute as)) <> "/>" +elementB (Elem n as cs@(c:_)) + | isText c = "<" <> (name n <+> fsep (map attribute as)) <> ">" <> + hcatMap contentB cs <> " name n <> ">" + | otherwise = "<" <> (name n <+> fsep (map attribute as)) <> ">" <> + hcatMap contentB cs <> " name n <> ">" isText :: Content t -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True isText _ = False -attribute (n,v) = text n <> "=" <> attvalue v +attribute (n,v) = name n <> "=" <> attvalue v contentB (CElem e _) = elementB e contentB (CString False s _) = chardata s @@ -193,7 +209,7 @@ contentB (CMisc m _) = misc m elementdecl :: ElementDecl -> MBuilder -elementdecl (ElementDecl n cs) = " text n <+> +elementdecl (ElementDecl n cs) = " name n <+> contentspec cs <> ">" contentspec :: ContentSpec -> MBuilder @@ -202,7 +218,7 @@ contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cpB c -cpB (TagName n m) = text n <> modifier m +cpB (TagName n m) = name n <> modifier m cpB (Choice cs m) = parens (intercalate "|" (map cpB cs)) <> modifier m cpB (Seq cs m) = parens (intercalate "," (map cpB cs)) <> modifier m @@ -214,28 +230,28 @@ mixed :: Mixed -> MBuilder mixed PCDATA = "(#PCDATA)" -mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map text ns) <> ")*" +mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*" attlistdecl :: AttListDecl -> MBuilder -attlistdecl (AttListDecl n ds) = " text n <+> +attlistdecl (AttListDecl n ds) = " name n <+> fsep (map attdef ds) <> ">" attdef :: AttDef -> MBuilder -attdef (AttDef n t d) = text n <+> atttype t <+> defaultdecl d +attdef (AttDef n t d) = name n <+> atttype t <+> defaultdecl d atttype :: AttType -> MBuilder -atttype StringType = "CDATA" -atttype (TokenizedType t) = tokenizedtype t -atttype (EnumeratedType t) = enumeratedtype t +atttype StringType = "CDATA" +atttype (TokenizedType t) = tokenizedtype t +atttype (EnumeratedType t) = enumeratedtype t tokenizedtype :: TokenizedType -> MBuilder -tokenizedtype ID = "ID" -tokenizedtype IDREF = "IDREF" -tokenizedtype IDREFS = "IDREFS" -tokenizedtype ENTITY = "ENTITY" -tokenizedtype ENTITIES = "ENTITIES" -tokenizedtype NMTOKEN = "NMTOKEN" -tokenizedtype NMTOKENS = "NMTOKENS" +tokenizedtype ID = "ID" +tokenizedtype IDREF = "IDREF" +tokenizedtype IDREFS = "IDREFS" +tokenizedtype ENTITY = "ENTITY" +tokenizedtype ENTITIES = "ENTITIES" +tokenizedtype NMTOKEN = "NMTOKEN" +tokenizedtype NMTOKENS = "NMTOKENS" enumeratedtype :: EnumeratedType -> MBuilder enumeratedtype (NotationType n) = notationtype n @@ -249,13 +265,13 @@ enumeration ns = parens (intercalate "|" (map nmtoken ns)) defaultdecl :: DefaultDecl -> MBuilder -defaultdecl REQUIRED = "#REQUIRED" -defaultdecl IMPLIED = "#IMPLIED" -defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a +defaultdecl REQUIRED = "#REQUIRED" +defaultdecl IMPLIED = "#IMPLIED" +defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a reference :: Reference -> MBuilder -reference (RefEntity er) = entityref er -reference (RefChar cr) = charref cr +reference (RefEntity er) = entityref er +reference (RefChar cr) = charref cr entityref :: [Char] -> MBuilder entityref n = "&" <> text n <> ";" @@ -264,8 +280,8 @@ charref c = "&#" <> text (show c) <> ";" entitydecl :: EntityDecl -> MBuilder -entitydecl (EntityGEDecl d) = gedecl d -entitydecl (EntityPEDecl d) = pedecl d +entitydecl (EntityGEDecl d) = gedecl d +entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> MBuilder gedecl (GEDecl n ed) = " text n <+> entitydef ed <> ">" @@ -278,12 +294,12 @@ entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> MBuilder -pedef (PEDefEntityValue ew) = entityvalue ew -pedef (PEDefExternalID eid) = externalid eid +pedef (PEDefEntityValue ew) = entityvalue ew +pedef (PEDefExternalID eid) = externalid eid externalid :: ExternalID -> MBuilder -externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl -externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl +externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl +externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> MBuilder ndatadecl (NDATA n) = "NDATA" <+> text n @@ -311,8 +327,8 @@ | otherwise = "\"" <> hcatMap ev evs <> "\"" ev :: EV -> MBuilder -ev (EVString s) = text s -ev (EVRef r) = reference r +ev (EVString s) = text s +ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> MBuilder pubidliteral (PubidLiteral s) 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,23 +21,23 @@ -- > main = cgiXmlRpcServer [("examples.add", fun add)] ----------------------------------------------------------------------------- -module Network.XmlRpc.Server +module Network.XmlRpc.Server ( XmlRpcMethod, ServerResult, fun, handleCall, methods, cgiXmlRpcServer, ) where -import Network.XmlRpc.Internals +import Network.XmlRpc.Internals -import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Codec.Binary.UTF8.String as U +import Control.Exception +import Control.Monad.Trans +import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as B -import Data.Maybe -import Control.Monad.Error -import Control.Exception -import qualified Codec.Binary.UTF8.String as U -import System.IO +import System.IO +serverName :: String serverName = "Haskell XmlRpcServer/0.1" -- @@ -62,8 +62,8 @@ -- Converting Haskell functions to XML-RPC methods -- --- | Turns any function --- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => +-- | Turns any function +-- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ -- into an 'XmlRpcMethod' fun :: XmlRpcFun a => a -> XmlRpcMethod @@ -75,15 +75,15 @@ instance XmlRpcType a => XmlRpcFun (IO a) where toFun x (MethodCall _ []) = do - v <- handleIO x - return (Return (toValue v)) + v <- handleIO x + return (Return (toValue v)) toFun _ _ = fail "Too many arguments" sig x = ([], getType (mType x)) instance (XmlRpcType a, XmlRpcFun b) => XmlRpcFun (a -> b) where toFun f (MethodCall n (x:xs)) = do - v <- fromValue x - toFun (f v) (MethodCall n xs) + v <- fromValue x + toFun (f v) (MethodCall n xs) toFun _ _ = fail "Too few arguments" sig f = let (a,b) = funType f (as, r) = sig b @@ -104,12 +104,12 @@ -- to generate a response and returns that response as a string handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString handleCall f str = do resp <- errorToResponse (parseCall str >>= f) - return (renderResponse resp) + return (renderResponse resp) -- | An XmlRpcMethod that looks up the method name in a table -- and uses that method to handle the call. methods :: [(String,XmlRpcMethod)] -> MethodCall -> ServerResult -methods t c@(MethodCall name _) = +methods t c@(MethodCall name _) = do (method,_) <- maybeToM ("Unknown method: " ++ name) (lookup name t) method c @@ -126,16 +126,16 @@ -- addIntrospection :: [(String,XmlRpcMethod)] -> [(String,XmlRpcMethod)] -addIntrospection t = t' - where t' = ("system.listMethods", fun (listMethods t')) : - ("system.methodSignature", fun (methodSignature t')) : - ("system.methodHelp", fun (methodHelp t')) : t +addIntrospection t = t' + where t' = ("system.listMethods", fun (listMethods t')) : + ("system.methodSignature", fun (methodSignature t')) : + ("system.methodHelp", fun (methodHelp t')) : t listMethods :: [(String,XmlRpcMethod)] -> IO [String] listMethods t = return (fst (unzip t)) methodSignature :: [(String,XmlRpcMethod)] -> String -> IO [[String]] -methodSignature t name = +methodSignature t name = do (_,(as,r)) <- maybeToM ("Unknown method: " ++ name) (lookup name t) return [map show (r:as)] @@ -148,7 +148,7 @@ -- FIXME: implement help :: XmlRpcMethod -> String -help m = "" +help _ = "" -- @@ -160,7 +160,7 @@ -- followed by the response to standard output. Supports -- introspection. cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO () -cgiXmlRpcServer ms = +cgiXmlRpcServer ms = do hSetBinaryMode stdin True hSetBinaryMode stdout True @@ -172,4 +172,4 @@ putStr ("Content-Length: " ++ show (B.length output) ++ crlf) putStr crlf B.putStr output - where crlf = "\r\n" + where crlf = "\r\n" diff --git a/Network/XmlRpc/THDeriveXmlRpcType.hs b/Network/XmlRpc/THDeriveXmlRpcType.hs --- a/Network/XmlRpc/THDeriveXmlRpcType.hs +++ b/Network/XmlRpc/THDeriveXmlRpcType.hs @@ -3,7 +3,7 @@ -- Module : Network.XmlRpc.THDeriveXmlRpcType -- Copyright : (c) Bjorn Bringert 2003-2005 -- License : BSD-style --- +-- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (requires extensions and non-portable libraries) @@ -12,14 +12,16 @@ -- ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} + module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where -import Control.Monad (replicateM, liftM) -import Data.List (genericLength) -import Data.Maybe (maybeToList) -import Language.Haskell.TH -import Network.XmlRpc.Internals hiding (Type) +import Control.Monad (liftM, replicateM) +import Data.List (genericLength) +import Data.Maybe (maybeToList) +import Language.Haskell.TH +import Network.XmlRpc.Internals hiding (Type) -- | Creates an 'XmlRpcType' instance which handles a Haskell record -- as an XmlRpc struct. Example: @@ -28,24 +30,28 @@ -- $(asXmlRpcStruct \'\'Person) -- @ asXmlRpcStruct :: Name -> Q [Dec] -asXmlRpcStruct name = +asXmlRpcStruct name = do info <- reify name dec <- case info of - TyConI d -> return d - _ -> fail $ show name ++ " is not a type constructor" + TyConI d -> return d + _ -> fail $ show name ++ " is not a type constructor" mkInstance dec mkInstance :: Dec -> Q [Dec] -mkInstance (DataD _ n _ [RecC c fs] _) = +#if MIN_VERSION_template_haskell(2,11,0) +mkInstance (DataD _ n _ _ [RecC c fs] _) = +#else +mkInstance (DataD _ n _ [RecC c fs] _) = +#endif do let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs) - tv <- mkToValue ns + tv <- mkToValue ns fv <- mkFromValue c ns gt <- mkGetType liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType) - (conT n)) - (map return $ concat [tv, fv, gt]) + (conT n)) + (map return $ concat [tv, fv, gt]) mkInstance _ = error "Can only derive XML-RPC type for simple record types" @@ -59,42 +65,42 @@ unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show mkToValue :: [(Name,Bool)] -> Q [Dec] -mkToValue fs = +mkToValue fs = do p <- newName "p" - simpleFun 'toValue [varP p] - (appE (varE 'toValue) - (appE [| concat |] $ listE $ map (fieldToTuple p) fs)) + simpleFun 'toValue [varP p] + (appE (varE 'toValue) + (appE [| concat |] $ listE $ map (fieldToTuple p) fs)) simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec] simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]] fieldToTuple :: Name -> (Name,Bool) -> ExpQ -fieldToTuple p (n,False) = listE [tupE [stringE (show n), - appE (varE 'toValue) - (appE (varE n) (varE p)) - ] - ] -fieldToTuple p (n,True) = +fieldToTuple p (n,False) = listE [tupE [stringE (show n), + appE (varE 'toValue) + (appE (varE n) (varE p)) + ] + ] +fieldToTuple p (n,True) = [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |] mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec] -mkFromValue c fs = +mkFromValue c fs = do names <- replicateM (length fs) (newName "x") v <- newName "v" t <- newName "t" - simpleFun 'fromValue [varP v] $ - doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++ - zipWith (mkGetField t) (map varP names) fs ++ - [noBindS $ appE [| return |] $ appsE (conE c:map varE names)] + simpleFun 'fromValue [varP v] $ + doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++ + zipWith (mkGetField t) (map varP names) fs ++ + [noBindS $ appE [| return |] $ appsE (conE c:map varE names)] -mkGetField t p (f,False) = bindS p (appsE [varE 'getField, - stringE (show f), varE t]) -mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, - stringE (show f), varE t]) +mkGetField t p (f,False) = bindS p (appsE [varE 'getField, + stringE (show f), varE t]) +mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, + stringE (show f), varE t]) mkGetType :: Q [Dec] -mkGetType = simpleFun 'getType [wildP] - (conE 'TStruct) +mkGetType = simpleFun 'getType [wildP] + (conE 'TStruct) diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,5 +1,5 @@ GHC = ghc -GHCFLAGS = -O2 -package haxr -fallow-overlapping-instances +GHCFLAGS = -O2 -package haxr -XOverlappingInstances TEST_PROGS = make-stubs parse_response \ person_server person_client raw_call \ diff --git a/examples/raw_call.hs b/examples/raw_call.hs --- a/examples/raw_call.hs +++ b/examples/raw_call.hs @@ -2,10 +2,11 @@ -- server and prints the response to standard output. Must be editied -- to use the right server URL. -import System (getArgs, exitFailure) -import IO (hPutStrLn, stderr) import Data.Char import Network.URI +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) import Network.XmlRpc.Internals import Network.HTTP diff --git a/examples/test_client.hs b/examples/test_client.hs --- a/examples/test_client.hs +++ b/examples/test_client.hs @@ -1,8 +1,9 @@ -- A simple client that calls the methods in test_server.hs -import System (getArgs, exitFailure) -import IO (hPutStrLn, stderr) -import Time +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import System.Time import Network.XmlRpc.Client diff --git a/examples/test_server.hs b/examples/test_server.hs --- a/examples/test_server.hs +++ b/examples/test_server.hs @@ -1,6 +1,6 @@ -- A simple server -import Time +import System.Time import Network.XmlRpc.Server add :: Int -> Int -> IO Int diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,39 +1,75 @@ Name: haxr -Version: 3000.8.2 -Cabal-version: >=1.6 +Version: 3000.11.6.1 +Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 License: BSD3 License-file: LICENSE Author: Bjorn Bringert -Maintainer: Gracjan Polak +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. Extra-Source-Files: + CHANGES examples/make-stubs.hs examples/parse_response.hs examples/Person.hs examples/PersonTH.hs examples/person_client.hs examples/person_server.hs examples/raw_call.hs examples/simple_client.hs examples/simple_server.hs examples/test_client.hs examples/test_server.hs examples/time-xmlrpc-com.hs examples/validate.hs examples/Makefile +Bug-reports: https://github.com/byorgey/haxr/issues +Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.2 || ==9.12.2 || ==9.14.1 +Source-repository head + type: git + location: https://github.com/byorgey/haxr + +flag network-uri + description: Get Network.URI from the network-uri package + default: True + Library - Build-depends: base < 5, mtl, network < 3, - HaXml == 1.20.*, HTTP >= 4000, bytestring, dataenc, - old-locale, old-time, time, array, utf8-string, - template-haskell, blaze-builder >= 0.2 && < 0.4 + Build-depends: base >= 4.9 && < 5, + base-compat >= 0.8 && < 1, + mtl < 3, + mtl-compat, + network < 4, + http-streams, + HsOpenSSL, + io-streams, + http-types, + HaXml >= 1.22, + http-streams, + bytestring, + base64-bytestring, + old-locale, + old-time, + time, + text, + array, + utf8-string, + template-haskell, + blaze-builder >= 0.2 + + if flag(network-uri) + build-depends: network-uri >= 2.6, network >= 2.6 + else + build-depends: network-uri < 2.6, network < 2.6 + Exposed-Modules: Network.XmlRpc.Client, Network.XmlRpc.Server, Network.XmlRpc.Internals, Network.XmlRpc.Introspect, Network.XmlRpc.THDeriveXmlRpcType, - Network.XmlRpc.Pretty - Other-Modules: - Network.XmlRpc.Base64, + Network.XmlRpc.Pretty, Network.XmlRpc.DTD_XMLRPC - Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances, TemplateHaskell + Other-Modules: + Network.XmlRpc.Base64 + Default-extensions: TypeSynonymInstances, FlexibleInstances + Other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell + Default-language: Haskell2010