haxr 3000.11.1.3 → 3000.11.1.4
raw patch · 7 files changed
+166/−155 lines, 7 filesdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
Files
- CHANGES +4/−0
- Network/XmlRpc/DTD_XMLRPC.hs +21/−21
- Network/XmlRpc/Internals.hs +83/−83
- Network/XmlRpc/Introspect.hs +7/−7
- Network/XmlRpc/Server.hs +9/−9
- Network/XmlRpc/THDeriveXmlRpcType.hs +40/−34
- haxr.cabal +2/−1
CHANGES view
@@ -1,3 +1,7 @@+* 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
Network/XmlRpc/DTD_XMLRPC.hs view
@@ -1,27 +1,27 @@ module Network.XmlRpc.DTD_XMLRPC where -import Text.XML.HaXml.XmlContent-import Text.XML.HaXml.OneOfN-import Text.XML.HaXml.Types (QName(..))+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)+newtype I4 = I4 String deriving (Eq,Show)+newtype I8 = I8 String deriving (Eq,Show)+newtype AInt = AInt String deriving (Eq,Show)+newtype Boolean = Boolean String deriving (Eq,Show)+newtype AString = AString String deriving (Eq,Show)+newtype ADouble = ADouble String deriving (Eq,Show)+newtype DateTime_iso8601 = DateTime_iso8601 String deriving (Eq,Show)+newtype Base64 = Base64 String deriving (Eq,Show)+newtype Data = Data [Value] deriving (Eq,Show)+newtype Array = Array Data deriving (Eq,Show)+newtype Name = Name String deriving (Eq,Show) data Member = Member Name Value deriving (Eq,Show)-newtype Struct = Struct [Member] deriving (Eq,Show)-newtype Value = Value [Value_] deriving (Eq,Show)+newtype Struct = Struct [Member] deriving (Eq,Show)+newtype Value = Value [Value_] deriving (Eq,Show) data Value_ = Value_Str String | Value_I4 I4 | Value_I8 I8@@ -34,12 +34,12 @@ | 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)+newtype Param = Param Value deriving (Eq,Show)+newtype Params = Params [Param] deriving (Eq,Show)+newtype MethodName = MethodName String deriving (Eq,Show) data MethodCall = MethodCall MethodName (Maybe Params) deriving (Eq,Show)-newtype Fault = Fault Value deriving (Eq,Show)+newtype Fault = Fault Value deriving (Eq,Show) data MethodResponse = MethodResponseParams Params | MethodResponseFault Fault deriving (Eq,Show)@@ -277,7 +277,7 @@ [CElem (Elem (N "methodResponse") [] (toContents a) ) ()] toContents (MethodResponseFault a) = [CElem (Elem (N "methodResponse") [] (toContents a) ) ()]- parseContents = do + parseContents = do { e@(Elem _ [] _) <- element ["methodResponse"] ; interior e $ oneOf [ return (MethodResponseParams) `apply` parseContents
Network/XmlRpc/Internals.hs view
@@ -71,10 +71,10 @@ -- | 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+ [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')@@ -83,17 +83,17 @@ -- | Convert a 'Maybe' value to a value in any monad maybeToM :: Monad m =>- String -- ^ Error message to fail with for 'Nothing'- -> Maybe a -- ^ The 'Maybe' value.- -> m a -- ^ The resulting value in the monad.+ String -- ^ Error message to fail with for 'Nothing'+ -> Maybe a -- ^ The 'Maybe' value.+ -> m a -- ^ The resulting value in the monad. maybeToM err Nothing = fail err maybeToM _ (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.+ -> 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 @@ -120,17 +120,17 @@ -- | Handle errors from the error monad. handleError :: Monad m => (String -> m a) -> Err m a -> m a handleError h m = do- Right x <- runExceptT (catchError m (lift . h))- return x+ Right x <- runExceptT (catchError m (lift . h))+ return x errorRead :: (Monad m, Read a) =>- ReadS a -- ^ Parser- -> String -- ^ Error message- -> String -- ^ String to parse- -> Err m a+ ReadS a -- ^ Parser+ -> String -- ^ Error message+ -> String -- ^ String to parse+ -> Err m a errorRead r err s = case [x | (x,t) <- r s, ("","") <- lex t] of- [x] -> return x- _ -> fail (err ++ ": '" ++ s ++ "'")+ [x] -> return x+ _ -> fail (err ++ ": '" ++ s ++ "'") -- -- Types for methods calls and responses@@ -139,12 +139,12 @@ -- | An XML-RPC method call. Consists of a method name and a list of -- parameters. data MethodCall = MethodCall String [Value]- deriving (Eq, Show) -- for debugging+ deriving (Eq, Show) -- for debugging -- | An XML-RPC response. data MethodResponse = Return Value -- ^ A method response returning a value- | Fault Int String -- ^ A fault response- deriving (Eq, Show) -- for debugging+ | Fault Int String -- ^ A fault response+ deriving (Eq, Show) -- for debugging -- | An XML-RPC value. data Value =@@ -161,15 +161,15 @@ -- | An XML-RPC value. Use for error messages and introspection. data Type =- TInt- | TBool- | TString- | TDouble- | TDateTime- | TBase64- | TStruct- | TArray- | TUnknown+ TInt+ | TBool+ | TString+ | TDouble+ | TDateTime+ | TBase64+ | TStruct+ | TArray+ | TUnknown deriving (Eq) instance Show Type where@@ -185,14 +185,14 @@ instance Read Type where readsPrec _ s = case break isSpace (dropWhile isSpace s) of- ("int",r) -> [(TInt,r)]- ("bool",r) -> [(TBool,r)]- ("string",r) -> [(TString,r)]- ("double",r) -> [(TDouble,r)]- ("dateTime.iso8601",r) -> [(TDateTime,r)]- ("base64",r) -> [(TBase64,r)]- ("struct",r) -> [(TStruct,r)]- ("array",r) -> [(TArray,r)]+ ("int",r) -> [(TInt,r)]+ ("bool",r) -> [(TBool,r)]+ ("string",r) -> [(TString,r)]+ ("double",r) -> [(TDouble,r)]+ ("dateTime.iso8601",r) -> [(TDateTime,r)]+ ("base64",r) -> [(TBase64,r)]+ ("struct",r) -> [(TStruct,r)]+ ("array",r) -> [(TArray,r)] -- | Gets the value of a struct member structGetValue :: Monad m => String -> Value -> Err m Value@@ -203,7 +203,7 @@ -- | Builds a fault struct faultStruct :: Int -> String -> Value faultStruct code str = ValueStruct [("faultCode",ValueInt code),- ("faultString",ValueString str)]+ ("faultString",ValueString str)] -- XML-RPC specification: -- "The body of the response is a single XML structure, a@@ -230,16 +230,16 @@ typeError :: (XmlRpcType a, Monad m) => Value -> Err m a typeError v = withType $ \t -> fail ("Wanted: "- ++ show (getType t)- ++ "', got: '"- ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t+ ++ show (getType t)+ ++ "', got: '"+ ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t -- a type hack for use in 'typeError' withType :: (a -> Err m a) -> Err m a withType f = f undefined simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a)- -> Value -> Err m a+ -> Value -> Err m a simpleFromValue f v = maybe (typeError v) return (f v) @@ -256,23 +256,23 @@ instance XmlRpcType Int where toValue = ValueInt fromValue = simpleFromValue f- where f (ValueInt x) = Just x- f _ = Nothing+ where f (ValueInt x) = Just x+ f _ = Nothing getType _ = TInt instance XmlRpcType Bool where toValue = ValueBool fromValue = simpleFromValue f- where f (ValueBool x) = Just x- f _ = Nothing+ where f (ValueBool x) = Just x+ f _ = Nothing getType _ = TBool instance XmlRpcType String where toValue = ValueString fromValue = simpleFromValue f- where f (ValueString x) = Just x+ where f (ValueString x) = Just x f (ValueUnwrapped x) = Just x- f _ = Nothing+ f _ = Nothing getType _ = TString instance XmlRpcType BS.ByteString where@@ -285,15 +285,15 @@ instance XmlRpcType Double where toValue = ValueDouble fromValue = simpleFromValue f- where f (ValueDouble x) = Just x- f _ = Nothing+ where f (ValueDouble x) = Just x+ f _ = Nothing getType _ = TDouble instance XmlRpcType LocalTime where toValue = ValueDateTime fromValue = simpleFromValue f- where f (ValueDateTime x) = Just x- f _ = Nothing+ where f (ValueDateTime x) = Just x+ f _ = Nothing getType _ = TDateTime instance XmlRpcType CalendarTime where@@ -305,8 +305,8 @@ instance XmlRpcType a => XmlRpcType [a] where toValue = ValueArray . map toValue fromValue v = case v of- ValueArray xs -> mapM fromValue xs- _ -> typeError v+ ValueArray xs -> mapM fromValue xs+ _ -> typeError v getType _ = TArray -- FIXME: struct elements may have different types@@ -314,8 +314,8 @@ toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs] fromValue v = case v of- ValueStruct xs -> mapM (\ (n,v') -> liftM ((,) n) (fromValue v')) xs- _ -> typeError v+ ValueStruct xs -> mapM (\ (n,v') -> liftM ((,) n) (fromValue v')) xs+ _ -> typeError v getType _ = TStruct -- Tuple instances may be used for heterogenous array types.@@ -353,20 +353,20 @@ -- | Get a field value from a (possibly heterogeneous) struct. getField :: (Monad m, XmlRpcType a) =>- String -- ^ Field name- -> [(String,Value)] -- ^ Struct- -> Err m a+ String -- ^ Field name+ -> [(String,Value)] -- ^ Struct+ -> Err m a getField x xs = maybeToM ("struct member " ++ show x ++ " not found")- (lookup x xs) >>= fromValue+ (lookup x xs) >>= fromValue -- | Get a field value from a (possibly heterogeneous) struct. getFieldMaybe :: (Monad m, XmlRpcType a) =>- String -- ^ Field name- -> [(String,Value)] -- ^ Struct- -> Err m (Maybe a)+ 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)+ Nothing -> return Nothing+ Just v -> liftM Just (fromValue v) -- -- Converting to XR types@@ -470,10 +470,10 @@ readBool :: Monad m => String -> Err m Bool readBool s = errorRead readsBool "Error parsing boolean" s where readsBool "true" = [(True,"")]- readsBool "false" = [(False,"")]- readsBool "1" = [(True,"")]- readsBool "0" = [(False,"")]- readsBool _ = []+ readsBool "false" = [(False,"")]+ readsBool "1" = [(True,"")]+ readsBool "0" = [(False,"")]+ readsBool _ = [] -- | From the XML-RPC specification: --@@ -485,7 +485,7 @@ -- seems unlikely to cause problems. readString :: Monad m => String -> Err m String readString = return . replace "&" "&" . replace "<" "<"- . replace ">" ">"+ . replace ">" ">" -- | From the XML-RPC specification:@@ -521,19 +521,19 @@ (_,_,wd) = toWeekDate (localDay l) (_,yd) = toOrdinalDate (localDay l) in CalendarTime {- ctYear = fromIntegral y,- ctMonth = toEnum (mo-1),- ctDay = d,- ctHour = h,- ctMin = mi,- ctSec = truncate s,- ctPicosec = 0,- ctWDay = toEnum (wd `mod` 7),- ctYDay = yd,- ctTZName = "UTC",- ctTZ = 0,- ctIsDST = False- }+ ctYear = fromIntegral y,+ ctMonth = toEnum (mo-1),+ ctDay = d,+ ctHour = h,+ ctMin = mi,+ ctSec = truncate s,+ ctPicosec = 0,+ ctWDay = toEnum (wd `mod` 7),+ ctYDay = yd,+ ctTZName = "UTC",+ ctTZ = 0,+ ctIsDST = False+ } calendarTimeToLocalTime :: CalendarTime -> LocalTime calendarTimeToLocalTime ct =
Network/XmlRpc/Introspect.hs view
@@ -1,7 +1,7 @@ module Network.XmlRpc.Introspect where -import Network.XmlRpc.Internals-import Network.XmlRpc.Client+import Network.XmlRpc.Client+import Network.XmlRpc.Internals type Signature = ([Type],Type) type Help = String@@ -21,11 +21,11 @@ signatures :: String -> String -> IO [Signature] signatures url name = do- sigs <- methodSignature url name- return [ (map read as,read r) | (r:as) <- sigs ]+ sigs <- methodSignature url name+ return [ (map read as,read r) | (r:as) <- sigs ] methodInfo :: String -> String -> IO MethodInfo methodInfo url name = do- sigs <- signatures url name- help <- methodHelp url name- return (name, sigs, help)+ sigs <- signatures url name+ help <- methodHelp url name+ return (name, sigs, help)
Network/XmlRpc/Server.hs view
@@ -75,15 +75,15 @@ instance XmlRpcType a => XmlRpcFun (IO a) where toFun x (MethodCall _ []) = do- v <- handleIO x- return (Return (toValue v))+ v <- handleIO x+ return (Return (toValue v)) toFun _ _ = fail "Too many arguments" sig x = ([], getType (mType x)) instance (XmlRpcType a, XmlRpcFun b) => XmlRpcFun (a -> b) where toFun f (MethodCall n (x:xs)) = do- v <- fromValue x- toFun (f v) (MethodCall n xs)+ v <- fromValue x+ toFun (f v) (MethodCall n xs) toFun _ _ = fail "Too few arguments" sig f = let (a,b) = funType f (as, r) = sig b@@ -104,7 +104,7 @@ -- to generate a response and returns that response as a string handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString handleCall f str = do resp <- errorToResponse (parseCall str >>= f)- return (renderResponse resp)+ return (renderResponse resp) -- | An XmlRpcMethod that looks up the method name in a table -- and uses that method to handle the call.@@ -127,9 +127,9 @@ 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+ 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))@@ -172,4 +172,4 @@ putStr ("Content-Length: " ++ show (B.length output) ++ crlf) putStr crlf B.putStr output- where crlf = "\r\n"+ where crlf = "\r\n"
Network/XmlRpc/THDeriveXmlRpcType.hs view
@@ -3,7 +3,7 @@ -- Module : Network.XmlRpc.THDeriveXmlRpcType -- Copyright : (c) Bjorn Bringert 2003-2005 -- License : BSD-style--- +-- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (requires extensions and non-portable libraries)@@ -12,14 +12,16 @@ -- ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}+ module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where -import Control.Monad (replicateM, liftM)-import Data.List (genericLength)-import Data.Maybe (maybeToList)-import Language.Haskell.TH-import Network.XmlRpc.Internals hiding (Type)+import Control.Monad (liftM, replicateM)+import Data.List (genericLength)+import Data.Maybe (maybeToList)+import Language.Haskell.TH+import Network.XmlRpc.Internals hiding (Type) -- | Creates an 'XmlRpcType' instance which handles a Haskell record -- as an XmlRpc struct. Example:@@ -28,24 +30,28 @@ -- $(asXmlRpcStruct \'\'Person) -- @ asXmlRpcStruct :: Name -> Q [Dec]-asXmlRpcStruct name = +asXmlRpcStruct name = do info <- reify name dec <- case info of- TyConI d -> return d- _ -> fail $ show name ++ " is not a type constructor"+ TyConI d -> return d+ _ -> fail $ show name ++ " is not a type constructor" mkInstance dec mkInstance :: Dec -> Q [Dec]-mkInstance (DataD _ n _ [RecC c fs] _) = +#if MIN_VERSION_template_haskell(2,11,0)+mkInstance (DataD _ n _ _ [RecC c fs] _) =+#else+mkInstance (DataD _ n _ [RecC c fs] _) =+#endif do let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs)- tv <- mkToValue ns + tv <- mkToValue ns fv <- mkFromValue c ns gt <- mkGetType liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType)- (conT n)) - (map return $ concat [tv, fv, gt])+ (conT n))+ (map return $ concat [tv, fv, gt]) mkInstance _ = error "Can only derive XML-RPC type for simple record types" @@ -59,42 +65,42 @@ unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show mkToValue :: [(Name,Bool)] -> Q [Dec]-mkToValue fs = +mkToValue fs = do p <- newName "p"- simpleFun 'toValue [varP p] - (appE (varE 'toValue)- (appE [| concat |] $ listE $ map (fieldToTuple p) fs))+ simpleFun 'toValue [varP p]+ (appE (varE 'toValue)+ (appE [| concat |] $ listE $ map (fieldToTuple p) fs)) simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec] simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]] fieldToTuple :: Name -> (Name,Bool) -> ExpQ-fieldToTuple p (n,False) = listE [tupE [stringE (show n), - appE (varE 'toValue)- (appE (varE n) (varE p))- ]- ]-fieldToTuple p (n,True) = +fieldToTuple p (n,False) = listE [tupE [stringE (show n),+ appE (varE 'toValue)+ (appE (varE n) (varE p))+ ]+ ]+fieldToTuple p (n,True) = [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |] mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]-mkFromValue c fs = +mkFromValue c fs = do names <- replicateM (length fs) (newName "x") v <- newName "v" t <- newName "t"- simpleFun 'fromValue [varP v] $ - doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++- zipWith (mkGetField t) (map varP names) fs ++ - [noBindS $ appE [| return |] $ appsE (conE c:map varE names)]+ simpleFun 'fromValue [varP v] $+ doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] +++ zipWith (mkGetField t) (map varP names) fs +++ [noBindS $ appE [| return |] $ appsE (conE c:map varE names)] -mkGetField t p (f,False) = bindS p (appsE [varE 'getField, - stringE (show f), varE t])-mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, - stringE (show f), varE t])+mkGetField t p (f,False) = bindS p (appsE [varE 'getField,+ stringE (show f), varE t])+mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe,+ stringE (show f), varE t]) mkGetType :: Q [Dec]-mkGetType = simpleFun 'getType [wildP] - (conE 'TStruct)+mkGetType = simpleFun 'getType [wildP]+ (conE 'TStruct)
haxr.cabal view
@@ -1,5 +1,5 @@ Name: haxr-Version: 3000.11.1.3+Version: 3000.11.1.4 Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006@@ -22,6 +22,7 @@ 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 == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Source-repository head type: git