diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/Network/XmlRpc/DTD_XMLRPC.hs b/Network/XmlRpc/DTD_XMLRPC.hs --- a/Network/XmlRpc/DTD_XMLRPC.hs +++ b/Network/XmlRpc/DTD_XMLRPC.hs @@ -1,27 +1,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 diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -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 = diff --git a/Network/XmlRpc/Introspect.hs b/Network/XmlRpc/Introspect.hs --- a/Network/XmlRpc/Introspect.hs +++ b/Network/XmlRpc/Introspect.hs @@ -1,7 +1,7 @@ module Network.XmlRpc.Introspect where -import Network.XmlRpc.Internals -import Network.XmlRpc.Client +import Network.XmlRpc.Client +import Network.XmlRpc.Internals type Signature = ([Type],Type) type Help = String @@ -21,11 +21,11 @@ signatures :: String -> String -> IO [Signature] signatures url name = do - sigs <- methodSignature url name - return [ (map read as,read r) | (r:as) <- sigs ] + sigs <- methodSignature url name + return [ (map read as,read r) | (r:as) <- sigs ] methodInfo :: String -> String -> IO MethodInfo methodInfo url name = do - sigs <- signatures url name - help <- methodHelp url name - return (name, sigs, help) + sigs <- signatures url name + help <- methodHelp url name + return (name, sigs, help) diff --git a/Network/XmlRpc/Server.hs b/Network/XmlRpc/Server.hs --- a/Network/XmlRpc/Server.hs +++ b/Network/XmlRpc/Server.hs @@ -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" diff --git a/Network/XmlRpc/THDeriveXmlRpcType.hs b/Network/XmlRpc/THDeriveXmlRpcType.hs --- a/Network/XmlRpc/THDeriveXmlRpcType.hs +++ b/Network/XmlRpc/THDeriveXmlRpcType.hs @@ -3,7 +3,7 @@ -- Module : Network.XmlRpc.THDeriveXmlRpcType -- Copyright : (c) Bjorn Bringert 2003-2005 -- License : BSD-style --- +-- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (requires extensions and non-portable libraries) @@ -12,14 +12,16 @@ -- ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} + module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where -import Control.Monad (replicateM, liftM) -import Data.List (genericLength) -import Data.Maybe (maybeToList) -import Language.Haskell.TH -import Network.XmlRpc.Internals hiding (Type) +import Control.Monad (liftM, replicateM) +import Data.List (genericLength) +import Data.Maybe (maybeToList) +import Language.Haskell.TH +import Network.XmlRpc.Internals hiding (Type) -- | Creates an 'XmlRpcType' instance which handles a Haskell record -- as an XmlRpc struct. Example: @@ -28,24 +30,28 @@ -- $(asXmlRpcStruct \'\'Person) -- @ asXmlRpcStruct :: Name -> Q [Dec] -asXmlRpcStruct name = +asXmlRpcStruct name = do info <- reify name dec <- case info of - TyConI d -> return d - _ -> fail $ show name ++ " is not a type constructor" + TyConI d -> return d + _ -> fail $ show name ++ " is not a type constructor" mkInstance dec mkInstance :: Dec -> Q [Dec] -mkInstance (DataD _ n _ [RecC c fs] _) = +#if MIN_VERSION_template_haskell(2,11,0) +mkInstance (DataD _ n _ _ [RecC c fs] _) = +#else +mkInstance (DataD _ n _ [RecC c fs] _) = +#endif do let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs) - tv <- mkToValue ns + tv <- mkToValue ns fv <- mkFromValue c ns gt <- mkGetType liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType) - (conT n)) - (map return $ concat [tv, fv, gt]) + (conT n)) + (map return $ concat [tv, fv, gt]) mkInstance _ = error "Can only derive XML-RPC type for simple record types" @@ -59,42 +65,42 @@ unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show mkToValue :: [(Name,Bool)] -> Q [Dec] -mkToValue fs = +mkToValue fs = do p <- newName "p" - simpleFun 'toValue [varP p] - (appE (varE 'toValue) - (appE [| concat |] $ listE $ map (fieldToTuple p) fs)) + simpleFun 'toValue [varP p] + (appE (varE 'toValue) + (appE [| concat |] $ listE $ map (fieldToTuple p) fs)) simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec] simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]] fieldToTuple :: Name -> (Name,Bool) -> ExpQ -fieldToTuple p (n,False) = listE [tupE [stringE (show n), - appE (varE 'toValue) - (appE (varE n) (varE p)) - ] - ] -fieldToTuple p (n,True) = +fieldToTuple p (n,False) = listE [tupE [stringE (show n), + appE (varE 'toValue) + (appE (varE n) (varE p)) + ] + ] +fieldToTuple p (n,True) = [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |] mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec] -mkFromValue c fs = +mkFromValue c fs = do names <- replicateM (length fs) (newName "x") v <- newName "v" t <- newName "t" - simpleFun 'fromValue [varP v] $ - doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++ - zipWith (mkGetField t) (map varP names) fs ++ - [noBindS $ appE [| return |] $ appsE (conE c:map varE names)] + simpleFun 'fromValue [varP v] $ + doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++ + zipWith (mkGetField t) (map varP names) fs ++ + [noBindS $ appE [| return |] $ appsE (conE c:map varE names)] -mkGetField t p (f,False) = bindS p (appsE [varE 'getField, - stringE (show f), varE t]) -mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, - stringE (show f), varE t]) +mkGetField t p (f,False) = bindS p (appsE [varE 'getField, + stringE (show f), varE t]) +mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, + stringE (show f), varE t]) mkGetType :: Q [Dec] -mkGetType = simpleFun 'getType [wildP] - (conE 'TStruct) +mkGetType = simpleFun 'getType [wildP] + (conE 'TStruct) diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -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