haxr-3000.11.4.1/0000755000000000000000000000000007346545000011312 5ustar0000000000000000haxr-3000.11.4.1/CHANGES0000755000000000000000000000677707346545000012331 0ustar0000000000000000* 3000.11.4.1 (9 July 2020) - Support GHC-8.10 * 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.* haxr-3000.11.4.1/LICENSE0000644000000000000000000000266707346545000012332 0ustar0000000000000000Copyright (c) 2003-2005 Bjorn Bringert. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of any contributors may be used to endorse or promote products derived from this software without specific prior written permission. This software is provided by the copyright holders "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no event shall the copyright holders be liable for any direct, indirect, incidental, special, exemplary, or consequential damages (including, but not limited to, procurement of substitute goods or services; loss of use, data, or profits; or business interruption) however caused and on any theory of liability, whether in contract, strict liability, or tort (including negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. haxr-3000.11.4.1/Network/XmlRpc/0000755000000000000000000000000007346545000014150 5ustar0000000000000000haxr-3000.11.4.1/Network/XmlRpc/Base64.hs0000644000000000000000000000040607346545000015530 0ustar0000000000000000module Network.XmlRpc.Base64 ( encode, decode ) where import Data.ByteString import qualified Data.ByteString.Base64 as B64 encode :: ByteString -> ByteString encode = B64.encode decode :: ByteString -> ByteString decode = B64.decodeLenient haxr-3000.11.4.1/Network/XmlRpc/Client.hs0000644000000000000000000002101707346545000015723 0ustar0000000000000000{-# 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) -- -- This module contains the client functionality of XML-RPC. -- The XML-RPC specifcation is available at . -- -- A simple client application: -- -- > import Network.XmlRpc.Client -- > -- > server = "http://localhost/~bjorn/cgi-bin/simple_server" -- > -- > add :: String -> Int -> Int -> IO Int -- > add url = remote url "examples.add" -- > -- > main = do -- > let x = 4 -- > y = 7 -- > z <- add server x y -- > putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z) -- ----------------------------------------------------------------------------- module Network.XmlRpc.Client ( remote, remoteWithHeaders, call, callWithHeaders, Remote ) where import Network.XmlRpc.Internals import Control.Monad.Fail (MonadFail) import qualified Control.Monad.Fail as Fail import Data.Functor ((<$>)) import Data.Int import Data.Maybe import Network.URI import Text.Read.Compat (readMaybe) import Network.Http.Client (Method (..), Request, baselineContextSSL, buildRequest, closeConnection, getStatusCode, getStatusMessage, http, inputStreamBody, openConnection, openConnectionSSL, receiveResponse, sendRequest, 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 :: 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 -> HeadersAList -> MethodCall -> Err IO MethodResponse doCall url headers mc = do let req = renderCall mc 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 -- 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 -- | 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. -> String -- ^ Remote method name. -> a -- ^ Any function -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m) -- | 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 instance XmlRpcType a => Remote (IO a) where remote_ h f = handleError (fail . h) $ f [] >>= fromValue instance (XmlRpcType a, Remote b) => Remote (a -> b) where remote_ h f x = remote_ h (\xs -> f (toValue x:xs)) -- -- HTTP functions -- userAgent :: BS.ByteString userAgent = "Haskell XmlRpcClient/0.1" -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail? post :: String -> HeadersAList -> BSL.ByteString -> IO U.ByteString post url headers content = do uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url) 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 -> 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 -> 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 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 , if null pw then Nothing else Just $ dropAtEnd $ tail pw ) -- -- Utility functions -- 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 haxr-3000.11.4.1/Network/XmlRpc/DTD_XMLRPC.hs0000644000000000000000000002666707346545000016225 0ustar0000000000000000module 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-} haxr-3000.11.4.1/Network/XmlRpc/Internals.hs0000644000000000000000000005455507346545000016461 0ustar0000000000000000{-# 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. -- Most applications should not need to use this module. Client -- applications should use "Network.XmlRpc.Client" and server applications should -- use "Network.XmlRpc.Server". -- -- The XML-RPC specifcation is available at . -- ----------------------------------------------------------------------------- #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 parseResponse, parseCall, getField, getFieldMaybe, -- * 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 Control.Exception import Control.Monad import Control.Monad.Except import qualified Control.Monad.Fail as Fail import Control.Monad.Fail (MonadFail) 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(..)) #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 -- -- | Replaces all occurances of a sublist in a list with another list. -- If the list to replace is the empty list, does nothing. replace :: Eq a => [a] -- ^ The sublist to replace when found -> [a] -- ^ The list to replace it with -> [a] -- ^ The list to replace in -> [a] -- ^ The result replace [] _ xs = xs replace _ _ [] = [] replace ys zs xs@(x:xs') | isPrefixOf ys xs = zs ++ replace ys zs (drop (length ys) xs) | otherwise = x : replace ys zs xs' -- | Convert a 'Maybe' value to a value in any monad maybeToM :: 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 :: 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.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 = ExceptT String m a -- | Evaluate the argument and catch error call exceptions 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 x = (liftIO x >>= return) `catchError` \e -> throwError (show e) -- | Handle errors from the error monad. 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 :: (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.fail (err ++ ": '" ++ s ++ "'") -- -- Types for methods calls and responses -- -- | An XML-RPC method call. Consists of a method name and a list of -- parameters. data MethodCall = MethodCall String [Value] deriving (Eq, Show) -- for debugging -- | An XML-RPC response. data MethodResponse = Return Value -- ^ A method response returning a value | Fault Int String -- ^ A fault response deriving (Eq, Show) -- for debugging -- | An XML-RPC value. data Value = ValueInt Int -- ^ int, i4, or i8 | ValueBool Bool -- ^ bool | ValueString String -- ^ string | ValueUnwrapped String -- ^ no inner element | ValueDouble Double -- ^ double | ValueDateTime LocalTime -- ^ dateTime.iso8601 | 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 | 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 | TNil deriving (Eq) instance Show Type where show TInt = "int" show TBool = "bool" show TString = "string" show TDouble = "double" show TDateTime = "dateTime.iso8601" show TBase64 = "base64" show TStruct = "struct" show TArray = "array" show TUnknown = "unknown" 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)] ("nil",r) -> [(TNil,r)] -- | Gets the value of a struct member 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 faultStruct :: Int -> String -> Value faultStruct code str = ValueStruct [("faultCode",ValueInt code), ("faultString",ValueString str)] -- XML-RPC specification: -- "The body of the response is a single XML structure, a -- , which can contain a single which contains a -- single which contains a single ." onlyOneResult :: 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 -- -- | A class for mapping Haskell types to XML-RPC types. class XmlRpcType a where -- | Convert from this type to a 'Value' toValue :: a -> Value -- | Convert from a 'Value' to this type. May fail if -- if there is a type error. fromValue :: MonadFail m => Value -> Err m a getType :: a -> Type typeError :: (XmlRpcType a, MonadFail m) => Value -> Err m a typeError v = withType $ \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 :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a) -> Value -> Err m a simpleFromValue f v = maybe (typeError v) return (f v) -- | Exists to allow explicit type conversions. instance XmlRpcType Value where toValue = id fromValue = return . id getType _ = TUnknown -- FIXME: instance for ()? instance XmlRpcType Int where toValue = ValueInt fromValue = simpleFromValue f where f (ValueInt x) = Just x f _ = Nothing getType _ = TInt instance XmlRpcType Bool where toValue = ValueBool fromValue = simpleFromValue f where f (ValueBool x) = Just x f _ = Nothing getType _ = TBool instance OVERLAPPING_ XmlRpcType String where toValue = ValueString fromValue = simpleFromValue f 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 getType _ = TDouble instance XmlRpcType LocalTime where toValue = ValueDateTime fromValue = simpleFromValue f where f (ValueDateTime x) = Just x f _ = Nothing getType _ = TDateTime instance XmlRpcType CalendarTime where toValue = toValue . calendarTimeToLocalTime 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 OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where toValue = ValueArray . map toValue fromValue v = case v of ValueArray xs -> mapM fromValue xs _ -> typeError v getType _ = TArray -- FIXME: struct elements may have different types 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 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 :: (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 :: (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 -- toXRValue :: Value -> XR.Value 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) = XR.Value [ XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 (showDateTime t))] toXRValue (ValueBase64 s) = XR.Value [XR.Value_Base64 (XR.Base64 (showBase64 s))] toXRValue (ValueStruct xs) = XR.Value [XR.Value_Struct (XR.Struct (map toXRMember xs))] toXRValue (ValueArray xs) = XR.Value [XR.Value_Array (XR.Array (XR.Data (map toXRValue xs)))] toXRValue ValueNil = XR.Value [XR.Value_Nil (XR.Nil ())] showInt :: Int -> String showInt = show showBool :: Bool -> String showBool b = if b then "1" else "0" -- escapes &, <, and < showString :: String -> String showString = replace ">" ">" . replace "<" "<" . replace "&" "&" -- | Shows a double in signed decimal point notation. showDouble :: Double -> String showDouble d = showFFloat Nothing d "" -- | Shows a date and time on the format: YYYYMMDDTHH:mm:SS showDateTime :: LocalTime -> String showDateTime t = formatTime defaultTimeLocale xmlRpcDateFormat t showBase64 :: BS.ByteString -> String showBase64 = BS.unpack . Base64.encode toXRMethodCall :: MethodCall -> XR.MethodCall toXRMethodCall (MethodCall name vs) = XR.MethodCall (XR.MethodName name) (Just (toXRParams vs)) toXRMethodResponse :: MethodResponse -> XR.MethodResponse toXRMethodResponse (Return val) = XR.MethodResponseParams (toXRParams [val]) toXRMethodResponse (Fault code str) = XR.MethodResponseFault (XR.Fault (toXRValue (faultStruct code str))) toXRParams :: [Value] -> XR.Params toXRParams vs = XR.Params (map (XR.Param . toXRValue) vs) toXRMember :: (String, Value) -> XR.Member toXRMember (n, v) = XR.Member (XR.Name n) (toXRValue v) -- -- Converting from XR types -- fromXRValue :: MonadFail m => XR.Value -> Err m Value fromXRValue (XR.Value vs) = case (filter notstr vs) of [] -> liftM (ValueUnwrapped . concat) (mapM (readString . unstr) vs) (v:_) -> f v where notstr (XR.Value_Str _) = False notstr _ = True unstr (XR.Value_Str x) = x f (XR.Value_I4 (XR.I4 x)) = liftM ValueInt (readInt x) f (XR.Value_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) f (XR.Value_AString (XR.AString x)) = liftM ValueString (readString x) f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 x)) = liftM ValueDateTime (readDateTime x) f (XR.Value_Base64 (XR.Base64 x)) = liftM ValueBase64 (readBase64 x) f (XR.Value_Struct (XR.Struct ms)) = liftM ValueStruct (mapM fromXRMember ms) f (XR.Value_Array (XR.Array (XR.Data xs))) = liftM ValueArray (mapM fromXRValue xs) f (XR.Value_Nil (XR.Nil x)) = return ValueNil 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: -- -- \"An integer is a 32-bit signed number. You can include a plus or -- minus at the beginning of a string of numeric characters. Leading -- zeros are collapsed. Whitespace is not permitted. Just numeric -- characters preceeded by a plus or minus.\" readInt :: 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 :: 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 _ = [] -- | From the XML-RPC specification: -- -- \"Any characters are allowed in a string except \< and &, which are -- encoded as < and &. A string can be used to encode binary data.\" -- -- To work with implementations (such as some Python bindings for example) -- which also escape \>, > is unescaped. This is non-standard, but -- seems unlikely to cause problems. readString :: Monad m => String -> Err m String readString = return . replace "&" "&" . replace "<" "<" . replace ">" ">" -- | From the XML-RPC specification: -- -- There is no representation for infinity or negative infinity or \"not -- a number\". At this time, only decimal point notation is allowed, a -- plus or a minus, followed by any number of numeric characters, -- followed by a period and any number of numeric -- characters. Whitespace is not allowed. The range of allowable values -- is implementation-dependent, is not specified. -- -- FIXME: accepts more than decimal point notation readDouble :: MonadFail m => String -> Err m Double readDouble s = errorRead reads "Error parsing double" s -- | From : -- -- \"Essentially \"dateTime.iso8601\" is a misnomer and the format of the -- content of this element should not be assumed to comply with the -- variants of the ISO8601 standard. Only assume YYYYMMDDTHH:mm:SS\" -- FIXME: make more robust readDateTime :: MonadFail m => String -> Err m LocalTime readDateTime dt = maybe (Fail.fail $ "Error parsing dateTime '" ++ dt ++ "'") return (parseTimeM True defaultTimeLocale xmlRpcDateFormat dt) localTimeToCalendarTime :: LocalTime -> CalendarTime 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 } calendarTimeToLocalTime :: CalendarTime -> LocalTime 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, localTimeOfDay = TimeOfDay { todHour = h, todMin = mi, todSec = fromIntegral s } } -- FIXME: what if data contains non-base64 characters? readBase64 :: Monad m => String -> Err m BS.ByteString readBase64 = return . Base64.decode . BS.pack fromXRParams :: MonadFail m => XR.Params -> Err m [Value] fromXRParams (XR.Params xps) = mapM (\(XR.Param v) -> fromXRValue v) xps fromXRMethodCall :: MonadFail m => XR.MethodCall -> Err m MethodCall fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = liftM (MethodCall name) (fromXRParams (fromMaybe (XR.Params []) params)) fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse fromXRMethodResponse (XR.MethodResponseParams xps) = liftM Return (fromXRParams xps >>= onlyOneResult) fromXRMethodResponse (XR.MethodResponseFault (XR.Fault v)) = do struct <- fromXRValue v vcode <- structGetValue "faultCode" struct code <- fromValue vcode vstr <- structGetValue "faultString" struct str <- fromValue vstr return (Fault code str) -- -- Parsing calls and reponses from XML -- -- | Parses a method call from XML. parseCall :: (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, MonadFail m) => String -> Err m MethodResponse parseResponse c = do mxr <- errorToErr (readXml c) xr <- eitherToM "Error parsing method response" mxr fromXRMethodResponse xr -- -- Rendering calls and reponses to XML -- -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML renderCall :: MethodCall -> BSL.ByteString renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML 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 "" haxr-3000.11.4.1/Network/XmlRpc/Introspect.hs0000644000000000000000000000171307346545000016640 0ustar0000000000000000module Network.XmlRpc.Introspect where import Network.XmlRpc.Client import Network.XmlRpc.Internals type Signature = ([Type],Type) type Help = String type MethodInfo = (String,[Signature],Help) -- Primitive introspection functions listMethods :: String -> IO [String] listMethods url = remote url "system.listMethods" methodSignature :: String -> String -> IO [[String]] methodSignature url = remote url "system.methodSignature" methodHelp :: String -> String -> IO String methodHelp url = remote url "system.methodHelp" signatures :: String -> String -> IO [Signature] signatures url name = do sigs <- methodSignature url name return [ (map read as,read r) | (r:as) <- sigs ] methodInfo :: String -> String -> IO MethodInfo methodInfo url name = do sigs <- signatures url name help <- methodHelp url name return (name, sigs, help) haxr-3000.11.4.1/Network/XmlRpc/Pretty.hs0000644000000000000000000003006607346545000016000 0ustar0000000000000000{-# 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) | isText (P.head cs) = "<" <> (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 haxr-3000.11.4.1/Network/XmlRpc/Server.hs0000644000000000000000000001221107346545000015747 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.XmlRpc.Server -- Copyright : (c) Bjorn Bringert 2003 -- License : BSD-style -- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (requires extensions and non-portable libraries) -- -- This module contains the server functionality of XML-RPC. -- The XML-RPC specifcation is available at . -- -- A simple CGI-based XML-RPC server application: -- -- > import Network.XmlRpc.Server -- > -- > add :: Int -> Int -> IO Int -- > add x y = return (x + y) -- > -- > main = cgiXmlRpcServer [("examples.add", fun add)] ----------------------------------------------------------------------------- module Network.XmlRpc.Server ( XmlRpcMethod, ServerResult, fun, handleCall, methods, cgiXmlRpcServer, ) where import Network.XmlRpc.Internals import qualified Codec.Binary.UTF8.String as U import Control.Exception import Control.Monad.Except import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as B import System.IO serverName :: String serverName = "Haskell XmlRpcServer/0.1" -- -- API -- type ServerResult = Err IO MethodResponse type Signature = ([Type], Type) -- | The type of XML-RPC methods on the server. type XmlRpcMethod = (MethodCall -> ServerResult, Signature) showException :: SomeException -> String showException = show handleIO :: IO a -> Err IO a handleIO io = lift (try io) >>= either (fail . showException) return -- -- Converting Haskell functions to XML-RPC methods -- -- | Turns any function -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ -- into an 'XmlRpcMethod' fun :: XmlRpcFun a => a -> XmlRpcMethod fun f = (toFun f, sig f) class XmlRpcFun a where toFun :: a -> MethodCall -> ServerResult sig :: a -> Signature instance XmlRpcType a => XmlRpcFun (IO a) where toFun x (MethodCall _ []) = do v <- handleIO x return (Return (toValue v)) toFun _ _ = fail "Too many arguments" sig 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) toFun _ _ = fail "Too few arguments" sig f = let (a,b) = funType f (as, r) = sig b in (getType a : as, r) mType :: m a -> a mType _ = undefined funType :: (a -> b) -> (a, b) funType _ = (undefined, undefined) -- FIXME: always returns error code 0 errorToResponse :: ServerResult -> IO MethodResponse errorToResponse = handleError (return . Fault 0) -- | Reads a method call from a string, uses the supplied method -- to generate a response and returns that response as a string handleCall :: (MethodCall -> ServerResult) -> String -> IO 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 _) = do (method,_) <- maybeToM ("Unknown method: " ++ name) (lookup name t) method c -- | A server with introspection support server :: [(String,XmlRpcMethod)] -> String -> IO ByteString server t = handleCall (methods (addIntrospection t)) -- -- Introspection -- addIntrospection :: [(String,XmlRpcMethod)] -> [(String,XmlRpcMethod)] addIntrospection t = t' where t' = ("system.listMethods", fun (listMethods t')) : ("system.methodSignature", fun (methodSignature t')) : ("system.methodHelp", fun (methodHelp t')) : t listMethods :: [(String,XmlRpcMethod)] -> IO [String] listMethods t = return (fst (unzip t)) methodSignature :: [(String,XmlRpcMethod)] -> String -> IO [[String]] methodSignature t name = do (_,(as,r)) <- maybeToM ("Unknown method: " ++ name) (lookup name t) return [map show (r:as)] methodHelp :: [(String,XmlRpcMethod)] -> String -> IO String methodHelp t name = do method <- maybeToM ("Unknown method: " ++ name) (lookup name t) return (help method) -- FIXME: implement help :: XmlRpcMethod -> String help _ = "" -- -- CGI server -- -- | A CGI-based XML-RPC server. Reads a request from standard input -- and writes some HTTP headers (Content-Type and Content-Length), -- followed by the response to standard output. Supports -- introspection. cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO () cgiXmlRpcServer ms = do 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 (B.length output) ++ crlf) putStr crlf B.putStr output where crlf = "\r\n" haxr-3000.11.4.1/Network/XmlRpc/THDeriveXmlRpcType.hs0000644000000000000000000000711707346545000020154 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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) haxr-3000.11.4.1/Setup.lhs0000644000000000000000000000015707346545000013125 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain haxr-3000.11.4.1/examples/0000755000000000000000000000000007346545000013130 5ustar0000000000000000haxr-3000.11.4.1/examples/Makefile0000755000000000000000000000070307346545000014573 0ustar0000000000000000GHC = 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) haxr-3000.11.4.1/examples/Person.hs0000755000000000000000000000154007346545000014735 0ustar0000000000000000-- | 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 haxr-3000.11.4.1/examples/PersonTH.hs0000755000000000000000000000070707346545000015175 0ustar0000000000000000{-# 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) haxr-3000.11.4.1/examples/make-stubs.hs0000755000000000000000000000451607346545000015550 0ustar0000000000000000-- 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 haxr-3000.11.4.1/examples/parse_response.hs0000755000000000000000000000040007346545000016511 0ustar0000000000000000-- 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) haxr-3000.11.4.1/examples/person_client.hs0000755000000000000000000000043607346545000016336 0ustar0000000000000000-- | 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 haxr-3000.11.4.1/examples/person_server.hs0000755000000000000000000000056107346545000016365 0ustar0000000000000000-- | 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)] haxr-3000.11.4.1/examples/raw_call.hs0000755000000000000000000000414207346545000015254 0ustar0000000000000000-- 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))] haxr-3000.11.4.1/examples/simple_client.hs0000755000000000000000000000050107346545000016312 0ustar0000000000000000-- 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) haxr-3000.11.4.1/examples/simple_server.hs0000755000000000000000000000023307346545000016344 0ustar0000000000000000-- A minimal server import Network.XmlRpc.Server add :: Int -> Int -> IO Int add x y = return (x + y) main = cgiXmlRpcServer [("examples.add", fun add)]haxr-3000.11.4.1/examples/test_client.hs0000755000000000000000000000202107346545000015777 0ustar0000000000000000-- 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 () haxr-3000.11.4.1/examples/test_server.hs0000755000000000000000000000054507346545000016040 0ustar0000000000000000-- 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)] haxr-3000.11.4.1/examples/time-xmlrpc-com.hs0000755000000000000000000000037507346545000016511 0ustar0000000000000000import 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) haxr-3000.11.4.1/examples/validate.hs0000755000000000000000000000445307346545000015266 0ustar0000000000000000-- Implements the validation suite from http://validator.xmlrpc.com/ -- This has not been tested as the XML-RPC validator does not seem to -- be working at the moment. import System.Time import Network.XmlRpc.Internals import Network.XmlRpc.Server get :: String -> [(String,a)] -> IO a get f xs = maybeToM ("No such field: '" ++ f ++ "'") (lookup f xs) arrayOfStructsTest :: [[(String,Int)]] -> IO Int arrayOfStructsTest xs = return $ sum [ i | Just i <- map (lookup "curly") xs] countTheEntities :: String -> IO [(String,Int)] countTheEntities xs = return [ ("ctLeftAngleBrackets", count '<'), ("ctRightAngleBrackets", count '>'), ("ctAmpersands", count '&'), ("ctApostrophes", count '\''), ("ctQuotes", count '"') ] where count c = length (filter (==c) xs) easyStructTest :: [(String,Int)] -> IO Int easyStructTest xs = do m <- get "moe" xs l <- get "larry" xs c <- get "curly" xs return (m+l+c) -- FIXME: should be able to get it as a struct echoStructTest :: Value -> IO Value echoStructTest xs = return xs manyTypesTest :: Int -> Bool -> String -> Double -> CalendarTime -> String -> IO [Value] manyTypesTest i b s d t b64 = return [toValue i, toValue b, toValue s, toValue d, toValue t, toValue b64] moderateSizeArrayCheck :: [String] -> IO String moderateSizeArrayCheck [] = fail "empty array" moderateSizeArrayCheck xs = return (head xs ++ last xs) nestedStructTest :: [(String,[(String,[(String,[(String,Int)])])])] -> IO Int nestedStructTest c = do y <- get "2000" c m <- get "04" y d <- get "01" m easyStructTest d simpleStructReturnTest :: Int -> IO [(String, Int)] simpleStructReturnTest x = return [ ("times10",10*x), ("times100",100*x), ("times1000",1000*x) ] main = cgiXmlRpcServer [ ("validator1.arrayOfStructsTest", fun arrayOfStructsTest), ("validator1.countTheEntities", fun countTheEntities), ("validator1.easyStructTest", fun easyStructTest), ("validator1.echoStructTest", fun echoStructTest), ("validator1.manyTypesTest", fun manyTypesTest), ("validator1.moderateSizeArrayCheck", fun moderateSizeArrayCheck), ("validator1.nestedStructTest", fun nestedStructTest), ("validator1.simpleStructReturnTest", fun simpleStructReturnTest) ] haxr-3000.11.4.1/haxr.cabal0000644000000000000000000000474107346545000013246 0ustar0000000000000000Name: haxr Version: 3000.11.4.1 Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 License: BSD3 License-file: LICENSE Author: Bjorn Bringert 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 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.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 Source-repository head type: git location: git://github.com/byorgey/haxr.git flag network-uri description: Get Network.URI from the network-uri package default: True Library Build-depends: base >= 4.9 && < 4.15, base-compat >= 0.8 && < 0.12, mtl, mtl-compat, network < 3.2, http-streams, HsOpenSSL, io-streams, http-types, HaXml >= 1.22 && < 1.26, http-streams, bytestring, base64-bytestring, old-locale, old-time, time, text, array, utf8-string, template-haskell, blaze-builder >= 0.2 && < 0.5 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, Network.XmlRpc.DTD_XMLRPC Other-Modules: Network.XmlRpc.Base64 Default-extensions: TypeSynonymInstances, FlexibleInstances Other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell Default-language: Haskell2010