diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,12 @@ +* 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 diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs --- a/Network/XmlRpc/Client.hs +++ b/Network/XmlRpc/Client.hs @@ -39,32 +39,35 @@ import Network.XmlRpc.Internals +import Control.Monad.Fail (MonadFail) +import qualified Control.Monad.Fail as Fail import Data.Functor ((<$>)) -import Data.Maybe 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, openConnection, - inputStreamBody, openConnectionSSL, - receiveResponse, sendRequest, - setAuthorizationBasic, - setContentType, setContentLength, setHeader) + 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, - unpack, length) + 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 :: Monad m => MethodResponse -> m Value -handleResponse (Return v) = return v +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)] @@ -223,8 +226,8 @@ -- Utility functions -- -maybeFail :: Monad m => String -> Maybe a -> m a -maybeFail msg = maybe (fail msg) return +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 diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -103,11 +103,11 @@ maybeToM _ (Just x) = return x -- | Convert a 'Maybe' value to a value in any monad -eitherToM :: Monad m +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 (err ++ ": " ++ s) +eitherToM err (Left s) = Fail.fail (err ++ ": " ++ s) eitherToM _ (Right x) = return x -- | The format for \"dateTime.iso8601\" @@ -136,14 +136,14 @@ Right x <- runExceptT (catchError m (lift . h)) return x -errorRead :: (Monad m, Read a) => +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 (err ++ ": '" ++ s ++ "'") + _ -> Fail.fail (err ++ ": '" ++ s ++ "'") -- -- Types for methods calls and responses @@ -222,10 +222,10 @@ -- "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 :: Monad m => [Value] -> Err m Value -onlyOneResult [] = fail "Method returned no result" +onlyOneResult :: MonadFail m => [Value] -> Err m Value +onlyOneResult [] = Fail.fail "Method returned no result" onlyOneResult [x] = return x -onlyOneResult _ = fail "Method returned more than one result" +onlyOneResult _ = Fail.fail "Method returned more than one result" -- -- Converting to and from XML-RPC types @@ -237,12 +237,12 @@ toValue :: a -> Value -- | Convert from a 'Value' to this type. May fail if -- if there is a type error. - fromValue :: Monad m => Value -> Err m a + fromValue :: MonadFail m => Value -> Err m a getType :: a -> Type -typeError :: (XmlRpcType a, Monad m) => Value -> Err m a +typeError :: (XmlRpcType a, MonadFail m) => Value -> Err m a typeError v = withType $ \t -> - fail ("Wanted: " + Fail.fail ("Wanted: " ++ show (getType t) ++ "', got: '" ++ showXml False (toXRValue v) ++ "'") `asTypeOf` return t @@ -251,7 +251,7 @@ withType :: (a -> Err m a) -> Err m a withType f = f undefined -simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a) +simpleFromValue :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a) -> Value -> Err m a simpleFromValue f v = maybe (typeError v) return (f v) @@ -378,7 +378,7 @@ (lookup x xs) >>= fromValue -- | Get a field value from a (possibly heterogeneous) struct. -getFieldMaybe :: (Monad m, XmlRpcType a) => +getFieldMaybe :: (MonadFail m, XmlRpcType a) => String -- ^ Field name -> [(String,Value)] -- ^ Struct -> Err m (Maybe a) @@ -443,7 +443,7 @@ -- Converting from XR types -- -fromXRValue :: Monad m => XR.Value -> Err m Value +fromXRValue :: MonadFail m => XR.Value -> Err m Value fromXRValue (XR.Value vs) = case (filter notstr vs) of [] -> liftM (ValueUnwrapped . concat) (mapM (readString . unstr) vs) @@ -469,7 +469,7 @@ liftM ValueArray (mapM fromXRValue xs) -fromXRMember :: Monad m => XR.Member -> Err m (String,Value) +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: @@ -478,14 +478,14 @@ -- 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 :: Monad m => String -> Err m Int +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 :: Monad m => String -> Err m Bool +readBool :: MonadFail m => String -> Err m Bool readBool s = errorRead readsBool "Error parsing boolean" s where readsBool "true" = [(True,"")] readsBool "false" = [(False,"")] @@ -516,7 +516,7 @@ -- is implementation-dependent, is not specified. -- -- FIXME: accepts more than decimal point notation -readDouble :: Monad m => String -> Err m Double +readDouble :: MonadFail m => String -> Err m Double readDouble s = errorRead reads "Error parsing double" s -- | From : @@ -525,10 +525,10 @@ -- 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 :: Monad m => String -> Err m LocalTime +readDateTime :: MonadFail m => String -> Err m LocalTime readDateTime dt = maybe - (fail $ "Error parsing dateTime '" ++ dt ++ "'") + (Fail.fail $ "Error parsing dateTime '" ++ dt ++ "'") return (parseTimeM True defaultTimeLocale xmlRpcDateFormat dt) @@ -566,10 +566,10 @@ readBase64 :: Monad m => String -> Err m BS.ByteString readBase64 = return . Base64.decode . BS.pack -fromXRParams :: Monad m => XR.Params -> Err m [Value] +fromXRParams :: MonadFail m => XR.Params -> Err m [Value] fromXRParams (XR.Params xps) = mapM (\(XR.Param v) -> fromXRValue v) xps -fromXRMethodCall :: Monad m => XR.MethodCall -> Err m MethodCall +fromXRMethodCall :: MonadFail m => XR.MethodCall -> Err m MethodCall fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = liftM (MethodCall name) (fromXRParams (fromMaybe (XR.Params []) params)) @@ -590,7 +590,7 @@ -- -- | Parses a method call from XML. -parseCall :: (Show e, MonadError e m) => String -> Err m MethodCall +parseCall :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodCall parseCall c = do mxc <- errorToErr (readXml c) diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,5 +1,5 @@ Name: haxr -Version: 3000.11.3 +Version: 3000.11.3.1 Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 @@ -22,7 +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 == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 +Tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 || ==8.8.1 Source-repository head type: git @@ -33,11 +33,11 @@ default: True Library - Build-depends: base >= 4.9 && < 4.13, - base-compat >= 0.8 && < 0.10, + Build-depends: base >= 4.9 && < 4.14, + base-compat >= 0.8 && < 0.11, mtl, mtl-compat, - network < 2.7, + network < 3.2, http-streams, HsOpenSSL, io-streams,