diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs --- a/Network/XmlRpc/Client.hs +++ b/Network/XmlRpc/Client.hs @@ -48,6 +48,8 @@ import Network.HTTP import Network.Stream +import qualified Data.ByteString.UTF8 as U +import qualified Data.ByteString as BS -- | Gets the return value from a method response. -- Throws an exception if the response was a fault. @@ -134,17 +136,17 @@ -- FIXME: remove --putStrLn (show (request uri content)) --putStrLn content - eresp <- simpleHTTP (request uri auth content) + eresp <- simpleHTTP (request uri auth (U.fromString content)) resp <- handleE (fail . show) eresp case rspCode resp of - (2,0,0) -> return (rspBody resp) + (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 -- | Create an XML-RPC compliant HTTP request. -request :: URI -> URIAuthority -> String -> Request_String +request :: URI -> URIAuthority -> BS.ByteString -> Request BS.ByteString request uri auth content = Request{ rqURI = uri, rqMethod = POST, rqHeaders = headers, @@ -153,7 +155,7 @@ -- the HTTP module adds a Host header based on the URI headers = [Header HdrUserAgent userAgent, Header HdrContentType "text/xml", - Header HdrContentLength (show (length content)) + Header HdrContentLength (show (BS.length content)) ] ++ maybeToList (authHdr (user auth) (password auth)) -- | Creates an Authorization header using the Basic scheme, diff --git a/Network/XmlRpc/DTD_XMLRPC.hs b/Network/XmlRpc/DTD_XMLRPC.hs --- a/Network/XmlRpc/DTD_XMLRPC.hs +++ b/Network/XmlRpc/DTD_XMLRPC.hs @@ -1,294 +1,275 @@ -module Network.XmlRpc.DTD_XMLRPC where - -import Text.XML.HaXml.Xml2Haskell -import Text.XML.HaXml.OneOfN -import Data.Char (isSpace) - - -{-Type decls-} - -newtype I4 = I4 String deriving (Eq,Show) -newtype AInt = AInt String deriving (Eq,Show) -newtype Boolean = Boolean String deriving (Eq,Show) -newtype AString = AString String deriving (Eq,Show) -newtype ADouble = ADouble String deriving (Eq,Show) -newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show) -newtype Base64 = Base64 String deriving (Eq,Show) -newtype Data = Data [Value] deriving (Eq,Show) -newtype Array = Array Data deriving (Eq,Show) -newtype Name = Name String deriving (Eq,Show) -data Member = Member Name Value - deriving (Eq,Show) -newtype Struct = Struct [Member] deriving (Eq,Show) -newtype Value = Value [Value_] deriving (Eq,Show) -data Value_ = Value_Str String - | Value_I4 I4 - | Value_AInt AInt - | Value_Boolean Boolean - | Value_AString AString - | Value_DateTime_iso8601 DateTime_iso8601 - | Value_ADouble ADouble - | Value_Base64 Base64 - | Value_Struct Struct - | Value_Array Array - deriving (Eq,Show) -newtype Param = Param Value deriving (Eq,Show) -newtype Params = Params [Param] deriving (Eq,Show) -newtype MethodName = MethodName String deriving (Eq,Show) -data MethodCall = MethodCall MethodName (Maybe Params) - deriving (Eq,Show) -newtype Fault = Fault Value deriving (Eq,Show) -data MethodResponse = MethodResponseParams Params - | MethodResponseFault Fault - deriving (Eq,Show) - - -{-Instance decls-} - -instance XmlContent I4 where - fromElem (CElem (Elem "i4" [] c0):rest) = - (\(a,ca)-> - (Just (I4 a), rest)) - (definite fromText "text" "i4" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (I4 a) = - [CElem (Elem "i4" [] (toText a))] -instance XmlContent AInt where - fromElem (CElem (Elem "int" [] c0):rest) = - (\(a,ca)-> - (Just (AInt a), rest)) - (definite fromText "text" "int" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (AInt a) = - [CElem (Elem "int" [] (toText a))] -instance XmlContent Boolean where - fromElem (CElem (Elem "boolean" [] c0):rest) = - (\(a,ca)-> - (Just (Boolean a), rest)) - (definite fromText "text" "boolean" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Boolean a) = - [CElem (Elem "boolean" [] (toText a))] -instance XmlContent AString where - fromElem (CElem (Elem "string" [] c0):rest) = - (\(a,ca)-> - (Just (AString a), rest)) - (definite fromText "text" "string" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (AString a) = - [CElem (Elem "string" [] (toText a))] -instance XmlContent ADouble where - fromElem (CElem (Elem "double" [] c0):rest) = - (\(a,ca)-> - (Just (ADouble a), rest)) - (definite fromText "text" "double" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (ADouble a) = - [CElem (Elem "double" [] (toText a))] -instance XmlContent DateTime_iso8601 where - fromElem (CElem (Elem "dateTime.iso8601" [] c0):rest) = - (\(a,ca)-> - (Just (DateTime_iso8601 a), rest)) - (definite fromText "text" "dateTime.iso8601" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (DateTime_iso8601 a) = - [CElem (Elem "dateTime.iso8601" [] (toText a))] -instance XmlContent Base64 where - fromElem (CElem (Elem "base64" [] c0):rest) = - (\(a,ca)-> - (Just (Base64 a), rest)) - (definite fromText "text" "base64" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Base64 a) = - [CElem (Elem "base64" [] (toText a))] -instance XmlContent Data where - fromElem (CElem (Elem "data" [] c0):rest) = - (\(a,ca)-> - (Just (Data a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Data a) = - [CElem (Elem "data" [] (concatMap toElem a))] -instance XmlContent Array where - fromElem (CElem (Elem "array" [] c0):rest) = - (\(a,ca)-> - (Just (Array a), rest)) - (definite fromElem "" "array" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Array a) = - [CElem (Elem "array" [] (toElem a))] -instance XmlContent Name where - fromElem (CElem (Elem "name" [] c0):rest) = - (\(a,ca)-> - (Just (Name a), rest)) - (definite fromText "text" "name" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Name a) = - [CElem (Elem "name" [] (toText a))] -instance XmlContent Member where - fromElem (CElem (Elem "member" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (Just (Member a b), rest)) - (definite fromElem "" "member" ca)) - (definite fromElem "" "member" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Member a b) = - [CElem (Elem "member" [] (toElem a ++ toElem b))] -instance XmlContent Struct where - fromElem (CElem (Elem "struct" [] c0):rest) = - (\(a,ca)-> - (Just (Struct a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Struct a) = - [CElem (Elem "struct" [] (concatMap toElem a))] -instance XmlContent Value where - fromElem (CElem (Elem "value" [] c0):rest) = - (\(a,ca)-> - (Just (Value a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Value a) = - [CElem (Elem "value" [] (concatMap toElem a))] -instance XmlContent Value_ where - fromElem c0 = - case (fromText c0) of - (Just a,rest) -> (Just (Value_Str a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_I4 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_AInt a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Boolean a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_AString a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_DateTime_iso8601 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_ADouble a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Base64 a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Struct a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,rest) -> (Just (Value_Array a), rest) - (_,_) -> - (Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Value_Str a) = toText a - toElem (Value_I4 a) = toElem a - toElem (Value_AInt a) = toElem a - toElem (Value_Boolean a) = toElem a - toElem (Value_AString a) = toElem a - toElem (Value_DateTime_iso8601 a) = toElem a - toElem (Value_ADouble a) = toElem a - toElem (Value_Base64 a) = toElem a - toElem (Value_Struct a) = toElem a - toElem (Value_Array a) = toElem a -instance XmlContent Param where - fromElem (CElem (Elem "param" [] c0):rest) = - (\(a,ca)-> - (Just (Param a), rest)) - (definite fromElem "" "param" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Param a) = - [CElem (Elem "param" [] (toElem a))] -instance XmlContent Params where - fromElem (CElem (Elem "params" [] c0):rest) = - (\(a,ca)-> - (Just (Params a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Params a) = - [CElem (Elem "params" [] (concatMap toElem a))] -instance XmlContent MethodName where - fromElem (CElem (Elem "methodName" [] c0):rest) = - (\(a,ca)-> - (Just (MethodName a), rest)) - (definite fromText "text" "methodName" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (MethodName a) = - [CElem (Elem "methodName" [] (toText a))] -instance XmlContent MethodCall where - fromElem (CElem (Elem "methodCall" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (Just (MethodCall a b), rest)) - (fromElem ca)) - (definite fromElem "" "methodCall" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (MethodCall a b) = - [CElem (Elem "methodCall" [] (toElem a ++ maybe [] toElem b))] -instance XmlContent Fault where - fromElem (CElem (Elem "fault" [] c0):rest) = - (\(a,ca)-> - (Just (Fault a), rest)) - (definite fromElem "" "fault" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (Fault a) = - [CElem (Elem "fault" [] (toElem a))] -instance XmlContent MethodResponse where - fromElem (CElem (Elem "methodResponse" [] c0):rest) = - case (fromElem c0) of - (Just a,_) -> (Just (MethodResponseParams a), rest) - (_,_) -> - case (fromElem c0) of - (Just a,_) -> (Just (MethodResponseFault a), rest) - (_,_) -> - (Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Nothing, rest) - toElem (MethodResponseParams a) = [CElem (Elem "methodResponse" [] (toElem a) )] - toElem (MethodResponseFault a) = [CElem (Elem "methodResponse" [] (toElem a) )] - - -{-Done-} +module Network.XmlRpc.DTD_XMLRPC where + +import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.OneOfN + + +{-Type decls-} + +newtype I4 = I4 String deriving (Eq,Show) +newtype AInt = AInt String deriving (Eq,Show) +newtype Boolean = Boolean String deriving (Eq,Show) +newtype AString = AString String deriving (Eq,Show) +newtype ADouble = ADouble String deriving (Eq,Show) +newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show) +newtype Base64 = Base64 String deriving (Eq,Show) +newtype Data = Data [Value] deriving (Eq,Show) +newtype Array = Array Data deriving (Eq,Show) +newtype Name = Name String deriving (Eq,Show) +data Member = Member Name Value + deriving (Eq,Show) +newtype Struct = Struct [Member] deriving (Eq,Show) +newtype Value = Value [Value_] deriving (Eq,Show) +data Value_ = Value_Str String + | Value_I4 I4 + | Value_AInt AInt + | Value_Boolean Boolean + | Value_AString AString + | Value_DateTime_iso8601 DateTime_iso8601 + | Value_ADouble ADouble + | Value_Base64 Base64 + | Value_Struct Struct + | Value_Array Array + deriving (Eq,Show) +newtype Param = Param Value deriving (Eq,Show) +newtype Params = Params [Param] deriving (Eq,Show) +newtype MethodName = MethodName String deriving (Eq,Show) +data MethodCall = MethodCall MethodName (Maybe Params) + deriving (Eq,Show) +newtype Fault = Fault Value deriving (Eq,Show) +data MethodResponse = MethodResponseParams Params + | MethodResponseFault Fault + deriving (Eq,Show) + + +{-Instance decls-} + +instance HTypeable I4 where + toHType x = Defined "i4" [] [] +instance XmlContent I4 where + toContents (I4 a) = + [CElem (Elem "i4" [] (toText a)) ()] + parseContents = do + { e@(Elem _ [] _) <- element ["i4"] + ; interior e $ return (I4) `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)) ()] + 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 "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 "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 "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 "dateTime.iso8601" [] (toText a)) ()] + parseContents = do + { e@(Elem _ [] _) <- element ["dateTime.iso8601"] + ; interior e $ return (DateTime_iso8601) + `apply` (text `onFail` return "") + } `adjustErr` ("in , "++) + +instance HTypeable Base64 where + toHType x = Defined "base64" [] [] +instance XmlContent Base64 where + toContents (Base64 a) = + [CElem (Elem "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 "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 "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 "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 "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 "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 "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_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 + parseContents = oneOf + [ return (Value_Str) `apply` text + , return (Value_I4) `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 + ] `adjustErr` ("in , "++) + +instance HTypeable Param where + toHType x = Defined "param" [] [] +instance XmlContent Param where + toContents (Param a) = + [CElem (Elem "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 "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 "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 "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 "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 "methodResponse" [] (toContents a) ) ()] + toContents (MethodResponseFault a) = + [CElem (Elem "methodResponse" [] (toContents a) ) ()] + parseContents = do + { e@(Elem _ [] _) <- element ["methodResponse"] + ; interior e $ oneOf + [ return (MethodResponseParams) `apply` parseContents + , return (MethodResponseFault) `apply` parseContents + ] `adjustErr` ("in , "++) + } + + + +{-Done-} diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -49,8 +49,9 @@ import Control.Monad.Identity import System.IO.Unsafe (unsafePerformIO) -import Text.XML.HaXml.Xml2Haskell ---import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.Pretty +import Text.PrettyPrint.HughesPJ import qualified Network.XmlRpc.Base64 as Base64 import qualified Network.XmlRpc.DTD_XMLRPC as XR @@ -232,7 +233,7 @@ fail ("Wanted: " ++ show (getType t) ++ "', got: '" - ++ showXml (toXRValue v) ++ "'") `asTypeOf` return t + ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t -- a type hack for use in 'typeError' withType :: (a -> Err m a) -> Err m a @@ -544,7 +545,7 @@ parseCall c = do mxc <- errorToErr (readXml c) - xc <- maybeToM "Error parsing method call" mxc + xc <- eitherToM "Error parsing method call" mxc fromXRMethodCall xc -- | Parses a method response from XML. @@ -552,7 +553,7 @@ parseResponse c = do mxr <- errorToErr (readXml c) - xr <- maybeToM "Error parsing method response" mxr + xr <- eitherToM "Error parsing method response" mxr fromXRMethodResponse xr -- @@ -562,9 +563,16 @@ -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML renderCall :: MethodCall -> String -renderCall = showXml . toXRMethodCall +renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML renderResponse :: MethodResponse -> String -renderResponse = showXml . toXRMethodResponse +renderResponse = showXml' False . toXRMethodResponse + +showXml' :: XmlContent a => Bool -> a -> String +showXml' dtd x = + let st = style{ mode = LeftMode } + in case toContents x of + [CElem _ _] -> (renderStyle st . document . toXml dtd) x + _ -> "" diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,12 +1,12 @@ Name: haxr -Version: 3000.2.1 +Version: 3000.5 Cabal-version: >=1.2 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 License: BSD3 License-file: LICENSE Author: Bjorn Bringert -Maintainer: Bjorn Bringert +Maintainer: Gracjan Polak Homepage: http://www.haskell.org/haxr/ Category: Network Synopsis: XML-RPC client and server library. @@ -14,12 +14,12 @@ HaXR is a library for writing XML-RPC client and server applications in Haskell. -flag old-base +Flag old-base description: Old, monolithic base default: False Library - Build-depends: base < 4, mtl, network, HaXml >= 1.13, HTTP >= 4000, dataenc, old-locale, old-time, time, array + Build-depends: base < 4, mtl, network, HaXml >= 1.20 && < 1.21, HTTP >= 4000, dataenc, old-locale, old-time, time, array, utf8-string, bytestring, pretty Exposed-Modules: Network.XmlRpc.Client, Network.XmlRpc.Server,