diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs --- a/Network/XmlRpc/Client.hs +++ b/Network/XmlRpc/Client.hs @@ -46,6 +46,7 @@ import Network.Socket (withSocketsDo) import Network.HTTP +import Network.Stream -- | Gets the return value from a method response. @@ -143,7 +144,7 @@ httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp -- | Create an XML-RPC compliant HTTP request. -request :: URI -> URIAuthority -> String -> Request +request :: URI -> URIAuthority -> String -> Request_String request uri auth content = Request{ rqURI = uri, rqMethod = POST, rqHeaders = headers, 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,296 +1,294 @@ -module Network.XmlRpc.DTD_XMLRPC where - -import Text.XML.HaXml.Xml2Haskell -import Text.XML.HaXml.OneOfN -import Data.Char (isSpace) -import Prelude hiding (String, Int, Double) -import qualified Prelude - - -{-Type decls-} - -newtype I4 = I4 Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype Int = Int Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype Boolean = Boolean Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype String = String Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype Double = Double Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype DateTime_iso8601 = DateTime_iso8601 Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype Base64 = Base64 Prelude.String deriving (Prelude.Eq,Prelude.Show) -newtype Data = Data [Value] deriving (Prelude.Eq,Prelude.Show) -newtype Array = Array Data deriving (Prelude.Eq,Prelude.Show) -newtype Name = Name Prelude.String deriving (Prelude.Eq,Prelude.Show) -data Member = Member Name Value - deriving (Prelude.Eq,Prelude.Show) -newtype Struct = Struct [Member] deriving (Prelude.Eq,Prelude.Show) -newtype Value = Value [Value_] deriving (Prelude.Eq,Prelude.Show) -data Value_ = Value_Str Prelude.String - | Value_I4 I4 - | Value_Int Int - | Value_Boolean Boolean - | Value_String String - | Value_DateTime_iso8601 DateTime_iso8601 - | Value_Double Double - | Value_Base64 Base64 - | Value_Struct Struct - | Value_Array Array - deriving (Prelude.Eq,Prelude.Show) -newtype Param = Param Value deriving (Prelude.Eq,Prelude.Show) -newtype Params = Params [Param] deriving (Prelude.Eq,Prelude.Show) -newtype MethodName = MethodName Prelude.String deriving (Prelude.Eq,Prelude.Show) -data MethodCall = MethodCall MethodName (Prelude.Maybe Params) - deriving (Prelude.Eq,Prelude.Show) -newtype Fault = Fault Value deriving (Prelude.Eq,Prelude.Show) -data MethodResponse = MethodResponseParams Params - | MethodResponseFault Fault - deriving (Prelude.Eq,Prelude.Show) - - -{-Instance decls-} - -instance XmlContent I4 where - fromElem (CElem (Elem "i4" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (I4 a) = - [CElem (Elem "i4" [] (toText a))] -instance XmlContent Int where - fromElem (CElem (Elem "int" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Int a), rest)) - (definite fromText "text" "int" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Int a) = - [CElem (Elem "int" [] (toText a))] -instance XmlContent Boolean where - fromElem (CElem (Elem "boolean" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (Boolean a) = - [CElem (Elem "boolean" [] (toText a))] -instance XmlContent String where - fromElem (CElem (Elem "string" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (String a), rest)) - (definite fromText "text" "string" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (String a) = - [CElem (Elem "string" [] (toText a))] -instance XmlContent Double where - fromElem (CElem (Elem "double" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Double a), rest)) - (definite fromText "text" "double" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Double a) = - [CElem (Elem "double" [] (toText a))] -instance XmlContent DateTime_iso8601 where - fromElem (CElem (Elem "dateTime.iso8601" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (DateTime_iso8601 a) = - [CElem (Elem "dateTime.iso8601" [] (toText a))] -instance XmlContent Base64 where - fromElem (CElem (Elem "base64" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (Base64 a) = - [CElem (Elem "base64" [] (toText a))] -instance XmlContent Data where - fromElem (CElem (Elem "data" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Data a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Data a) = - [CElem (Elem "data" [] (concatMap toElem a))] -instance XmlContent Array where - fromElem (CElem (Elem "array" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Array a), rest)) - (definite fromElem "" "array" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Array a) = - [CElem (Elem "array" [] (toElem a))] -instance XmlContent Name where - fromElem (CElem (Elem "name" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (Name a) = - [CElem (Elem "name" [] (toText a))] -instance XmlContent Member where - fromElem (CElem (Elem "member" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (Prelude.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 = (Prelude.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)-> - (Prelude.Just (Struct a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Struct a) = - [CElem (Elem "struct" [] (concatMap toElem a))] -instance XmlContent Value where - fromElem (CElem (Elem "value" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Value a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Value a) = - [CElem (Elem "value" [] (concatMap toElem a))] -instance XmlContent Value_ where - fromElem c0 = - case (fromText c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Str a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_I4 a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Int a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Boolean a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_String a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_DateTime_iso8601 a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Double a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Base64 a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Struct a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,rest) -> (Prelude.Just (Value_Array a), rest) - (_,_) -> - (Prelude.Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Value_Str a) = toText a - toElem (Value_I4 a) = toElem a - toElem (Value_Int a) = toElem a - toElem (Value_Boolean a) = toElem a - toElem (Value_String a) = toElem a - toElem (Value_DateTime_iso8601 a) = toElem a - toElem (Value_Double 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)-> - (Prelude.Just (Param a), rest)) - (definite fromElem "" "param" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Param a) = - [CElem (Elem "param" [] (toElem a))] -instance XmlContent Params where - fromElem (CElem (Elem "params" [] c0):rest) = - (\(a,ca)-> - (Prelude.Just (Params a), rest)) - (many fromElem c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Params a) = - [CElem (Elem "params" [] (concatMap toElem a))] -instance XmlContent MethodName where - fromElem (CElem (Elem "methodName" [] c0):rest) = - (\(a,ca)-> - (Prelude.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 = (Prelude.Nothing, rest) - toElem (MethodName a) = - [CElem (Elem "methodName" [] (toText a))] -instance XmlContent MethodCall where - fromElem (CElem (Elem "methodCall" [] c0):rest) = - (\(a,ca)-> - (\(b,cb)-> - (Prelude.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 = (Prelude.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)-> - (Prelude.Just (Fault a), rest)) - (definite fromElem "" "fault" c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.Nothing, rest) - toElem (Fault a) = - [CElem (Elem "fault" [] (toElem a))] -instance XmlContent MethodResponse where - fromElem (CElem (Elem "methodResponse" [] c0):rest) = - case (fromElem c0) of - (Prelude.Just a,_) -> (Prelude.Just (MethodResponseParams a), rest) - (_,_) -> - case (fromElem c0) of - (Prelude.Just a,_) -> (Prelude.Just (MethodResponseFault a), rest) - (_,_) -> - (Prelude.Nothing, c0) - fromElem (CMisc _:rest) = fromElem rest - fromElem (CString _ s:rest) | all isSpace s = fromElem rest - fromElem rest = (Prelude.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.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-} diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -50,6 +50,7 @@ import System.IO.Unsafe (unsafePerformIO) import Text.XML.HaXml.Xml2Haskell +--import Text.XML.HaXml.XmlContent import qualified Network.XmlRpc.Base64 as Base64 import qualified Network.XmlRpc.DTD_XMLRPC as XR @@ -79,6 +80,14 @@ maybeToM err Nothing = fail err maybeToM _ (Just x) = return x +-- | Convert a 'Maybe' value to a value in any monad +eitherToM :: Monad m + => String -- ^ Error message to fail with for 'Nothing' + -> Either String a -- ^ The 'Maybe' value. + -> m a -- ^ The resulting value in the monad. +eitherToM err (Left s) = fail (err ++ ": " ++ s) +eitherToM _ (Right x) = return x + -- | The format for \"dateTime.iso8601\" xmlRpcDateFormat = "%Y%m%dT%H:%M:%S" @@ -324,10 +333,10 @@ -- toXRValue :: Value -> XR.Value -toXRValue (ValueInt x) = XR.Value [XR.Value_Int (XR.Int (showInt x))] +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_String (XR.String (showString s))] -toXRValue (ValueDouble d) = XR.Value [XR.Value_Double (XR.Double (showDouble d))] +toXRValue (ValueString s) = XR.Value [XR.Value_AString (XR.AString (showString 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))] @@ -392,10 +401,10 @@ unstr (XR.Value_Str x) = x f (XR.Value_I4 (XR.I4 x)) = liftM ValueInt (readInt x) - f (XR.Value_Int (XR.Int 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_Double (XR.Double x)) = liftM ValueDouble (readDouble x) - f (XR.Value_String (XR.String x)) = liftM ValueString (readString 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) diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,5 +1,5 @@ Name: haxr -Version: 3000.1.1.2 +Version: 3000.2.0 Cabal-version: >=1.2 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 @@ -8,19 +8,22 @@ Author: Bjorn Bringert Maintainer: Bjorn Bringert Homepage: http://www.haskell.org/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. -Flag split-base +flag old-base + description: Old, monolithic base + default: False Library - Build-depends: mtl, network, HaXml >= 1.13 && < 1.14, HTTP >= 1.0, dataenc == 0.11.1 - if flag(split-base) - Build-depends: base == 3.*, array, old-time, old-locale, time + Build-depends: mtl, network, HaXml >= 1.13, HTTP >= 4000, dataenc, old-locale, old-time, time, array + if flag(old-base) + Build-Depends: base < 4 else - Build-depends: base < 3.0 + Build-Depends: base >= 4 Exposed-Modules: Network.XmlRpc.Client, Network.XmlRpc.Server,