We once had a class, FromString, that duplicated the functionality of the libary given class Error.
We have since then replaced all uses of FromString with Error. Now, Error is deprecated (since mtl >= 2.2.1). Hence, we are reintroducing FromString, and are replacing all uses of Error with it. The patch that removed FromString in favor of Error is: a87a017b023e2979b73f11dcf9012602bfa4b13c Signed-off-by: Bhimanavajjula Aditya <[email protected]> --- src/Ganeti/BasicTypes.hs | 78 +++++++++++++++++++------------- src/Ganeti/Codec.hs | 10 ++-- src/Ganeti/Errors.hs | 6 +-- src/Ganeti/HTools/Types.hs | 7 +-- src/Ganeti/JQueue.hs | 2 +- src/Ganeti/JSON.hs | 10 ++-- src/Ganeti/Logging.hs | 6 +-- src/Ganeti/Network.hs | 28 ++++++------ src/Ganeti/Objects/BitArray.hs | 4 +- src/Ganeti/Query/Exec.hs | 6 +-- src/Ganeti/Query/Server.hs | 2 +- src/Ganeti/Runtime.hs | 3 +- src/Ganeti/THH/HsRPC.hs | 2 +- src/Ganeti/THH/RPC.hs | 6 +-- src/Ganeti/Utils.hs | 1 - src/Ganeti/Utils/Atomic.hs | 6 +-- src/Ganeti/Utils/Livelock.hs | 4 +- src/Ganeti/Utils/Monad.hs | 2 +- src/Ganeti/Utils/UniStd.hs | 2 +- src/Ganeti/Utils/Validate.hs | 14 +++--- src/Ganeti/WConfd/Client.hs | 2 +- src/Ganeti/WConfd/ConfigModifications.hs | 2 +- src/Ganeti/WConfd/ConfigVerify.hs | 3 +- src/Ganeti/WConfd/ConfigWriter.hs | 3 +- src/Ganeti/WConfd/Monad.hs | 1 - src/Ganeti/WConfd/Persistent.hs | 2 +- src/Ganeti/WConfd/Server.hs | 5 +- src/Ganeti/WConfd/TempRes.hs | 2 +- 28 files changed, 119 insertions(+), 100 deletions(-) diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs index 0591fa3..2347b5a 100644 --- a/src/Ganeti/BasicTypes.hs +++ b/src/Ganeti/BasicTypes.hs @@ -51,6 +51,7 @@ module Ganeti.BasicTypes , tryError , Error(..) -- re-export from Control.Monad.Error , MonadIO(..) -- re-export from Control.Monad.IO.Class + , FromString(..) , isOk , isBad , justOk @@ -117,30 +118,42 @@ genericResult _ g (Ok b) = g b -- | Type alias for a string Result. type Result = GenericResult String +-- | Type class for things that can be built from strings. +class FromString a where + mkFromString :: String -> a + +-- | Trivial 'String' instance; requires FlexibleInstances extension +-- though. +instance FromString [Char] where + mkFromString = id + +instance FromString IOError where + mkFromString = userError + -- | 'Monad' instance for 'GenericResult'. -instance (Error a) => Monad (GenericResult a) where +instance (FromString a) => Monad (GenericResult a) where (>>=) (Bad x) _ = Bad x (>>=) (Ok x) fn = fn x return = Ok - fail = Bad . strMsg + fail = Bad . mkFromString instance Functor (GenericResult a) where fmap _ (Bad msg) = Bad msg fmap fn (Ok val) = Ok (fn val) -instance (Error a, Monoid a) => Alternative (GenericResult a) where - empty = Bad $ strMsg "zero Result when used as empty" +instance (FromString a, Monoid a) => Alternative (GenericResult a) where + empty = Bad $ mkFromString "zero Result when used as empty" -- for mplus, when we 'add' two Bad values, we concatenate their -- error descriptions - (Bad x) <|> (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y) + (Bad x) <|> (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` y) (Bad _) <|> x = x x@(Ok _) <|> _ = x -instance (Error a, Monoid a) => MonadPlus (GenericResult a) where +instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where mzero = empty mplus = (<|>) -instance (Error a) => MonadError a (GenericResult a) where +instance (FromString a) => MonadError a (GenericResult a) where throwError = Bad {-# INLINE throwError #-} catchError x h = genericResult h (const x) x @@ -173,16 +186,16 @@ elimResultT l r = ResultT . (runResultT . result <=< runResultT) result (Bad e) = l e {-# INLINE elimResultT #-} -instance (Applicative m, Monad m, Error a) => Applicative (ResultT a m) where +instance (Monad m, FromString a) => Applicative (ResultT a m) where pure = return (<*>) = ap -instance (Monad m, Error a) => Monad (ResultT a m) where - fail err = ResultT (return . Bad $ strMsg err) +instance (Monad m, FromString a) => Monad (ResultT a m) where + fail err = ResultT (return . Bad $ mkFromString err) return = lift . return (>>=) = flip (elimResultT throwError) -instance (Monad m, Error a) => MonadError a (ResultT a m) where +instance (Monad m, FromString a) => MonadError a (ResultT a m) where throwError = ResultT . return . Bad catchError = catchErrorT @@ -190,24 +203,24 @@ instance MonadTrans (ResultT a) where lift = ResultT . liftM Ok -- | The instance catches any 'IOError' using 'try' and converts it into an --- error message using 'strMsg'. +-- error message using 'mkFromString'. -- -- This way, monadic code within 'ResultT' that uses solely 'liftIO' to -- include 'IO' actions ensures that all IO exceptions are handled. -- -- Other exceptions (see instances of 'Exception') are not currently handled. -- This might be revised in the future. -instance (MonadIO m, Error a) => MonadIO (ResultT a m) where +instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where liftIO = ResultT . liftIO . liftM (either (failError . show) return) . (try :: IO a -> IO (Either IOError a)) -instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where +instance (MonadBase IO m, FromString a) => MonadBase IO (ResultT a m) where liftBase = ResultT . liftBase . liftM (either (failError . show) return) . (try :: IO a -> IO (Either IOError a)) -instance (Error a) => MonadTransControl (ResultT a) where +instance (FromString a) => MonadTransControl (ResultT a) where #if MIN_VERSION_monad_control(1,0,0) -- Needs Undecidable instances type StT (ResultT a) b = GenericResult a b @@ -221,7 +234,7 @@ instance (Error a) => MonadTransControl (ResultT a) where {-# INLINE liftWith #-} {-# INLINE restoreT #-} -instance (Error a, MonadBaseControl IO m) +instance (FromString a, MonadBaseControl IO m) => MonadBaseControl IO (ResultT a m) where #if MIN_VERSION_monad_control(1,0,0) -- Needs Undecidable instances @@ -238,7 +251,7 @@ instance (Error a, MonadBaseControl IO m) {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} -instance (Monad m, Error a, Monoid a) +instance (Monad m, FromString a, Monoid a) => Alternative (ResultT a m) where empty = ResultT $ return mzero -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit @@ -246,7 +259,7 @@ instance (Monad m, Error a, Monoid a) x <|> y = elimResultT combine return x where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) -instance (Monad m, Error a, Monoid a) +instance (Monad m, FromString a, Monoid a) => MonadPlus (ResultT a m) where mzero = empty mplus = (<|>) @@ -259,7 +272,7 @@ withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a withError f = genericResult (throwError . f) return -- | Changes the error message of a @ResultT@ value, if present. -withErrorT :: (Monad m, Error e) +withErrorT :: (Monad m, FromString e) => (e' -> e) -> ResultT e' m a -> ResultT e m a withErrorT f = ResultT . liftM (withError f) . runResultT @@ -275,10 +288,10 @@ toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a toErrorBase = (toError =<<) . liftBase . runResultT {-# INLINE toErrorBase #-} --- | An alias for @withError strMsg@, which is often used to lift a pure error --- to a monad stack. See also 'annotateResult'. -toErrorStr :: (MonadError e m, Error e) => Result a -> m a -toErrorStr = withError strMsg +-- | An alias for @withError mkFromString@, which is often +-- used to lift a pure error to a monad stack. See also 'annotateResult'. +toErrorStr :: (MonadError e m, FromString e) => Result a -> m a +toErrorStr = withError mkFromString -- | Run a given computation and if an error occurs, return it as `Left` of -- `Either`. @@ -295,11 +308,11 @@ tryError = flip catchError (return . Left) . liftM Right -- should be handled by the given action. -- -- See also 'toErrorStr'. -mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a +mkResultT :: (Monad m, FromString e) => m (Result a) -> ResultT e m a mkResultT = ResultT . liftM toErrorStr -- | Generalisation of mkResultT accepting any showable failures. -mkResultT' :: (Monad m, Error e, Show s) +mkResultT' :: (Monad m, FromString e, Show s) => m (GenericResult s a) -> ResultT e m a mkResultT' = mkResultT . liftM (genericResult (Bad . show) Ok) @@ -340,32 +353,33 @@ isRight = not . isLeft -- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself, -- it's a generalization of type @String -> Result a -> Result a@. -- See also 'toErrorStr'. -annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a +annotateResult :: (MonadError e m, FromString e) => String -> Result a -> m a annotateResult owner = toErrorStr . annotateError owner -- | Annotate an error with an ownership information inside a 'MonadError'. -- See also 'annotateResult'. -annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a +annotateError :: (MonadError e m, FromString e, Monoid e) + => String -> m a -> m a annotateError owner = - flip catchError (throwError . mappend (strMsg $ owner ++ ": ")) + flip catchError (throwError . mappend (mkFromString $ owner ++ ": ")) {-# INLINE annotateError #-} -- | Throws a 'String' message as an error in a 'MonadError'. -- This is a generalization of 'Bad'. -- It's similar to 'fail', but works within a 'MonadError', avoiding the -- unsafe nature of 'fail'. -failError :: (MonadError e m, Error e) => String -> m a -failError = throwError . strMsg +failError :: (MonadError e m, FromString e) => String -> m a +failError = throwError . mkFromString -- | A synonym for @flip@ 'catchErrorT'. -handleErrorT :: (Monad m, Error e) +handleErrorT :: (Monad m, FromString e) => (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a handleErrorT handler = elimResultT handler return {-# INLINE handleErrorT #-} -- | Catches an error in a @ResultT@ value. This is similar to 'catchError', -- but in addition allows to change the error type. -catchErrorT :: (Monad m, Error e) +catchErrorT :: (Monad m, FromString e) => ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a catchErrorT = flip handleErrorT {-# INLINE catchErrorT #-} diff --git a/src/Ganeti/Codec.hs b/src/Ganeti/Codec.hs index 85ce266..6f36cc6 100644 --- a/src/Ganeti/Codec.hs +++ b/src/Ganeti/Codec.hs @@ -39,22 +39,26 @@ module Ganeti.Codec import Codec.Compression.Zlib (compress) import qualified Codec.Compression.Zlib.Internal as I -import Control.Monad.Error +import Control.Monad (liftM) +import Control.Monad.Error.Class (MonadError(..)) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BL import Data.Monoid (mempty) +import Ganeti.BasicTypes + -- | Compresses a lazy bytestring. compressZlib :: BL.ByteString -> BL.ByteString compressZlib = compress -- | Decompresses a lazy bytestring, throwing decoding errors using -- 'throwError'. -decompressZlib :: (MonadError e m, Error e) => BL.ByteString -> m BL.ByteString +decompressZlib :: (MonadError e m, FromString e) + => BL.ByteString -> m BL.ByteString decompressZlib = I.foldDecompressStream (liftM . BL.chunk) (return mempty) - (const $ throwError . strMsg . ("Zlib: " ++)) + (const $ throwError . mkFromString . ("Zlib: " ++)) . I.decompressWithErrors I.zlibFormat I.defaultDecompressParams diff --git a/src/Ganeti/Errors.hs b/src/Ganeti/Errors.hs index 0ec175c..613c9cf 100644 --- a/src/Ganeti/Errors.hs +++ b/src/Ganeti/Errors.hs @@ -122,13 +122,13 @@ $(genException "GanetiException" , ("FileStoragePathError", [excErrMsg]) ]) -instance Error GanetiException where - strMsg = GenericError - instance JSON GanetiException where showJSON = saveGanetiException readJSON = loadGanetiException +instance FromString GanetiException where + mkFromString = GenericError + -- | Error monad using 'GanetiException' type alias. type ErrorResult = GenericResult GanetiException diff --git a/src/Ganeti/HTools/Types.hs b/src/Ganeti/HTools/Types.hs index 4e3ca8a..3fca797 100644 --- a/src/Ganeti/HTools/Types.hs +++ b/src/Ganeti/HTools/Types.hs @@ -377,10 +377,11 @@ type FailStats = [(FailMode, Int)] -- will instead raise an exception. type OpResult = GenericResult FailMode --- | 'Error' instance for 'FailMode' designed to catch unintended +-- | 'FromString' instance for 'FailMode' designed to catch unintended -- use as a general monad. -instance Error FailMode where - strMsg v = error $ "Programming error: OpResult used as generic monad" ++ v +instance FromString FailMode where + mkFromString v = error $ "Programming error: OpResult used as generic monad" + ++ v -- | Conversion from 'OpResult' to 'Result'. opToResult :: OpResult a -> Result a diff --git a/src/Ganeti/JQueue.hs b/src/Ganeti/JQueue.hs index 49f8b5e..bf103f7 100644 --- a/src/Ganeti/JQueue.hs +++ b/src/Ganeti/JQueue.hs @@ -483,7 +483,7 @@ replicateManyJobs rootdir mastercandidates = mapM_ (replicateJob rootdir mastercandidates) -- | Writes a job to a file and replicates it to master candidates. -writeAndReplicateJob :: (Error e) +writeAndReplicateJob :: (FromString e) => ConfigData -> FilePath -> QueuedJob -> ResultT e IO [(Node, ERpcError ())] writeAndReplicateJob cfg rootdir job = do diff --git a/src/Ganeti/JSON.hs b/src/Ganeti/JSON.hs index e1c91b3..6ce0f62 100644 --- a/src/Ganeti/JSON.hs +++ b/src/Ganeti/JSON.hs @@ -85,7 +85,7 @@ module Ganeti.JSON import Control.Applicative import Control.DeepSeq -import Control.Monad.Error.Class +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer import qualified Data.Foldable as F import qualified Data.Text as T @@ -150,8 +150,8 @@ fromJResult s (J.Error x) = fail (s ++ ": " ++ x) fromJResult _ (J.Ok x) = return x -- | Converts a JSON Result into a MonadError value. -fromJResultE :: (Error e, MonadError e m) => String -> J.Result a -> m a -fromJResultE s (J.Error x) = throwError . strMsg $ s ++ ": " ++ x +fromJResultE :: (FromString e, MonadError e m) => String -> J.Result a -> m a +fromJResultE s (J.Error x) = throwError . mkFromString $ s ++ ": " ++ x fromJResultE _ (J.Ok x) = return x -- | Tries to read a string from a JSON value. @@ -249,10 +249,10 @@ fromJVal v = J.Ok x -> return x -- | Small wrapper over 'readJSON' for 'MonadError'. -fromJValE :: (Error e, MonadError e m, J.JSON a) => J.JSValue -> m a +fromJValE :: (FromString e, MonadError e m, J.JSON a) => J.JSValue -> m a fromJValE v = case J.readJSON v of - J.Error s -> throwError . strMsg $ + J.Error s -> throwError . mkFromString $ "Cannot convert value '" ++ show (pp_value v) ++ "', error: " ++ s J.Ok x -> return x diff --git a/src/Ganeti/Logging.hs b/src/Ganeti/Logging.hs index bb23d8c..089df02 100644 --- a/src/Ganeti/Logging.hs +++ b/src/Ganeti/Logging.hs @@ -63,7 +63,7 @@ module Ganeti.Logging import Control.Applicative ((<$>)) import Control.Monad -import Control.Monad.Error (Error(..), MonadError(..), catchError) +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader import qualified Control.Monad.RWS.Strict as RWSS import qualified Control.Monad.State.Strict as SS @@ -77,7 +77,7 @@ import System.Log.Handler (setFormatter, LogHandler) import System.Log.Formatter import System.IO -import Ganeti.BasicTypes (ResultT(..)) +import Ganeti.BasicTypes (ResultT(..), FromString(..)) import Ganeti.THH import qualified Ganeti.ConstantUtils as ConstantUtils @@ -169,7 +169,7 @@ instance (MonadLog m) => MonadLog (SS.StateT s m) where instance (MonadLog m, Monoid w) => MonadLog (RWSS.RWST r w s m) where logAt p = lift . logAt p -instance (MonadLog m, Error e) => MonadLog (ResultT e m) where +instance (MonadLog m, FromString e) => MonadLog (ResultT e m) where logAt p = lift . logAt p -- | Log at debug level. diff --git a/src/Ganeti/Network.hs b/src/Ganeti/Network.hs index c3cf128..f2feebf 100644 --- a/src/Ganeti/Network.hs +++ b/src/Ganeti/Network.hs @@ -54,7 +54,7 @@ module Ganeti.Network ) where import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import Control.Monad.State import Data.Function (on) @@ -90,7 +90,7 @@ netIpv4NumHosts :: Network -> Integer netIpv4NumHosts = ipv4NumHosts . ip4netMask . networkNetwork -- | Creates a new bit array pool of the appropriate size -newPoolArray :: (MonadError e m, Error e) => Network -> m BA.BitArray +newPoolArray :: (MonadError e m, FromString e) => Network -> m BA.BitArray newPoolArray net = do let numhosts = netIpv4NumHosts net when (numhosts > ipv4NetworkMaxNumHosts) . failError $ @@ -104,15 +104,15 @@ newPoolArray net = do return $ BA.zeroes (fromInteger numhosts) -- | Creates a new bit array pool of the appropriate size -newPool :: (MonadError e m, Error e) => Network -> m AddressPool +newPool :: (MonadError e m, FromString e) => Network -> m AddressPool newPool = liftM AddressPool . newPoolArray -- | A helper function that creates a bit array pool, of it's missing. -orNewPool :: (MonadError e m, Error e) +orNewPool :: (MonadError e m, FromString e) => Network -> Maybe AddressPool -> m AddressPool orNewPool net = maybe (newPool net) return -withPool :: (MonadError e m, Error e) +withPool :: (MonadError e m, FromString e) => PoolPart -> (Network -> BA.BitArray -> m (a, BA.BitArray)) -> StateT Network m a withPool part f = StateT $ \n -> mapMOf2 (poolLens part) (f' n) n @@ -121,7 +121,7 @@ withPool part f = StateT $ \n -> mapMOf2 (poolLens part) (f' n) n . mapMOf2 addressPoolIso (f net) <=< orNewPool net -withPool_ :: (MonadError e m, Error e) +withPool_ :: (MonadError e m, FromString e) => PoolPart -> (Network -> BA.BitArray -> m BA.BitArray) -> Network -> m Network withPool_ part f = execStateT $ withPool part ((liftM ((,) ()) .) . f) @@ -129,12 +129,12 @@ withPool_ part f = execStateT $ withPool part ((liftM ((,) ()) .) . f) readPool :: PoolPart -> Network -> Maybe BA.BitArray readPool = view . poolArrayLens -readPoolE :: (MonadError e m, Error e) +readPoolE :: (MonadError e m, FromString e) => PoolPart -> Network -> m BA.BitArray readPoolE part net = liftM apReservations $ orNewPool net ((view . poolLens) part net) -readAllE :: (MonadError e m, Error e) +readAllE :: (MonadError e m, FromString e) => Network -> m BA.BitArray readAllE net = do let toRes = liftM apReservations . orNewPool net @@ -172,7 +172,7 @@ getMap = maybe "" (BA.asString '.' 'X') . allReservations -- | Returns an address index wrt a network. -- Fails if the address isn't in the network range. -addrIndex :: (MonadError e m, Error e) => Ip4Address -> Network -> m Int +addrIndex :: (MonadError e m, FromString e) => Ip4Address -> Network -> m Int addrIndex addr net = do let n = networkNetwork net i = on (-) ip4AddressToNumber addr (ip4netAddr n) @@ -182,7 +182,7 @@ addrIndex addr net = do -- | Returns an address of a given index wrt a network. -- Fails if the index isn't in the network range. -addrAt :: (MonadError e m, Error e) => Int -> Network -> m Ip4Address +addrAt :: (MonadError e m, FromString e) => Int -> Network -> m Ip4Address addrAt i net | (i' < 0) || (i' >= ipv4NumHosts (ip4netMask n)) = failError $ "Requested index " ++ show i ++ " outside the range of network '" ++ show net ++ "'" @@ -194,13 +194,13 @@ addrAt i net | (i' < 0) || (i' >= ipv4NumHosts (ip4netMask n)) = -- | Checks if a given address is reserved. -- Fails if the address isn't in the network range. -isReserved :: (MonadError e m, Error e) => +isReserved :: (MonadError e m, FromString e) => PoolPart -> Ip4Address -> Network -> m Bool isReserved part addr net = (BA.!) `liftM` readPoolE part net `ap` addrIndex addr net -- | Marks an address as used. -reserve :: (MonadError e m, Error e) => +reserve :: (MonadError e m, FromString e) => PoolPart -> Ip4Address -> Network -> m Network reserve part addr = withPool_ part $ \net ba -> do @@ -212,7 +212,7 @@ reserve part addr = BA.setAt idx True ba -- | Marks an address as unused. -release :: (MonadError e m, Error e) => +release :: (MonadError e m, FromString e) => PoolPart -> Ip4Address -> Network -> m Network release part addr = withPool_ part $ \net ba -> do @@ -225,7 +225,7 @@ release part addr = -- | Get the first free address in the network -- that satisfies a given predicate. -findFree :: (MonadError e m, Error e) +findFree :: (MonadError e m, FromString e) => (Ip4Address -> Bool) -> Network -> m (Maybe Ip4Address) findFree p net = readAllE net >>= BA.foldr f (return Nothing) where diff --git a/src/Ganeti/Objects/BitArray.hs b/src/Ganeti/Objects/BitArray.hs index 0ae784b..f121ba4 100644 --- a/src/Ganeti/Objects/BitArray.hs +++ b/src/Ganeti/Objects/BitArray.hs @@ -58,7 +58,7 @@ module Ganeti.Objects.BitArray import Prelude hiding (foldr) import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import qualified Data.IntSet as IS import qualified Text.JSON as J @@ -116,7 +116,7 @@ infixl 9 ! -- | Sets or removes an element from a bit array. -- | Sets a given bit in an array. Fails if the index is out of bounds. -setAt :: (MonadError e m, Error e) => Int -> Bool -> BitArray -> m BitArray +setAt :: (MonadError e m, FromString e) => Int -> Bool -> BitArray -> m BitArray setAt i False (BitArray s bits) = return $ BitArray s (IS.delete i bits) setAt i True (BitArray s bits) | (i >= 0) && (i < s) = diff --git a/src/Ganeti/Query/Exec.hs b/src/Ganeti/Query/Exec.hs index 124f7f3..4b2945b 100644 --- a/src/Ganeti/Query/Exec.hs +++ b/src/Ganeti/Query/Exec.hs @@ -64,7 +64,7 @@ import Control.Concurrent (rtsSupportsBoundThreads) import Control.Concurrent.Lifted (threadDelay) import Control.Exception (finally) import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError(..)) import Data.Functor import qualified Data.Map as M import Data.Maybe (listToMaybe, mapMaybe) @@ -103,7 +103,7 @@ connectConfig = ConnectConfig { recvTmo = 30 } -- Returns the list of all open file descriptors of the current process. -listOpenFds :: (Error e) => ResultT e IO [Fd] +listOpenFds :: (FromString e) => ResultT e IO [Fd] listOpenFds = liftM filterReadable $ liftIO (getDirectoryContents "/proc/self/fd") `orElse` liftIO (getDirectoryContents "/dev/fd") `orElse` @@ -224,7 +224,7 @@ forkWithPipe conf childAction = do -- | Forks the job process and starts processing of the given job. -- Returns the livelock of the job and its process ID. -forkJobProcess :: (Error e, Show e) +forkJobProcess :: (FromString e, Show e) => QueuedJob -- ^ a job to process -> FilePath -- ^ the daemons own livelock file -> (FilePath -> ResultT e IO ()) diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs index 3ea20bf..bf63cfa 100644 --- a/src/Ganeti/Query/Server.hs +++ b/src/Ganeti/Query/Server.hs @@ -46,7 +46,7 @@ import Control.Exception import Control.Lens ((.~)) import Control.Monad (forever, when, mzero, guard, zipWithM, liftM, void) import Control.Monad.Base (MonadBase, liftBase) -import Control.Monad.Error (MonadError) +import Control.Monad.Error.Class (MonadError) import Control.Monad.IO.Class import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe diff --git a/src/Ganeti/Runtime.hs b/src/Ganeti/Runtime.hs index 60a8848..8cf497f 100644 --- a/src/Ganeti/Runtime.hs +++ b/src/Ganeti/Runtime.hs @@ -52,7 +52,6 @@ module Ganeti.Runtime ) where import Control.Monad -import Control.Monad.Error import qualified Data.Map as M import System.Exit import System.FilePath @@ -195,7 +194,7 @@ allGroups = map DaemonGroup [minBound..maxBound] ++ map ExtraGroup [minBound..maxBound] -- | Computes the group/user maps. -getEnts :: (Error e) => ResultT e IO RuntimeEnts +getEnts :: (FromString e) => ResultT e IO RuntimeEnts getEnts = do let userOf = liftM userID . liftIO . getUserEntryForName . daemonUser let groupOf = liftM groupID . liftIO . getGroupEntryForName . daemonGroup diff --git a/src/Ganeti/THH/HsRPC.hs b/src/Ganeti/THH/HsRPC.hs index 7822912..8a352fa 100644 --- a/src/Ganeti/THH/HsRPC.hs +++ b/src/Ganeti/THH/HsRPC.hs @@ -46,7 +46,7 @@ module Ganeti.THH.HsRPC import Control.Applicative import Control.Monad import Control.Monad.Base -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import Control.Monad.Reader import Control.Monad.Trans.Control import Language.Haskell.TH diff --git a/src/Ganeti/THH/RPC.hs b/src/Ganeti/THH/RPC.hs index 08ae0a3..4b019ee 100644 --- a/src/Ganeti/THH/RPC.hs +++ b/src/Ganeti/THH/RPC.hs @@ -45,7 +45,7 @@ module Ganeti.THH.RPC import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad -import Control.Monad.Error.Class +import Control.Monad.Error.Class (MonadError(..)) import Data.Map (Map) import qualified Data.Map as Map import Language.Haskell.TH @@ -78,12 +78,12 @@ dispatch fs = , US.hExec = liftToHandler . exec } where - orError :: (MonadError e m, Error e) => Maybe a -> e -> m a + orError :: (MonadError e m, FromString e) => Maybe a -> e -> m a orError m e = maybe (throwError e) return m exec (Request m as) = do (RpcFn f) <- orError (Map.lookup m fs) - (strMsg $ "No such method: " ++ m) + (mkFromString $ "No such method: " ++ m) i <- fromJResultE "RPC input" . J.readJSON $ as o <- f i -- lift $ f i return $ J.showJSON o diff --git a/src/Ganeti/Utils.hs b/src/Ganeti/Utils.hs index 4cb6f57..0c599bb 100644 --- a/src/Ganeti/Utils.hs +++ b/src/Ganeti/Utils.hs @@ -105,7 +105,6 @@ import Control.Applicative import Control.Concurrent import Control.Exception (try, bracket) import Control.Monad -import Control.Monad.Error import qualified Data.Attoparsec.ByteString as A import qualified Data.ByteString.UTF8 as UTF8 import Data.Char (toUpper, isAlphaNum, isDigit, isSpace) diff --git a/src/Ganeti/Utils/Atomic.hs b/src/Ganeti/Utils/Atomic.hs index 7f4d2df..ae7bf81 100644 --- a/src/Ganeti/Utils/Atomic.hs +++ b/src/Ganeti/Utils/Atomic.hs @@ -43,7 +43,7 @@ module Ganeti.Utils.Atomic import qualified Control.Exception.Lifted as L import Control.Monad import Control.Monad.Base (MonadBase(..)) -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import Control.Monad.Trans.Control import System.FilePath.Posix (takeDirectory, takeBaseName) import System.IO @@ -91,12 +91,12 @@ atomicUpdateFile path action = do -- | Opens a file in a R/W mode, locks it (blocking if needed) and runs -- a given action while the file is locked. Releases the lock and -- closes the file afterwards. -withLockedFile :: (MonadError e m, Error e, MonadBaseControl IO m) +withLockedFile :: (MonadError e m, FromString e, MonadBaseControl IO m) => FilePath -> (Fd -> m a) -> m a withLockedFile path = L.bracket (openAndLock path) (liftBase . closeFd) where - openAndLock :: (MonadError e m, Error e, MonadBaseControl IO m) + openAndLock :: (MonadError e m, FromString e, MonadBaseControl IO m) => FilePath -> m Fd openAndLock p = liftBase $ do fd <- openFd p ReadWrite Nothing defaultFileFlags diff --git a/src/Ganeti/Utils/Livelock.hs b/src/Ganeti/Utils/Livelock.hs index 8bbb37f..905cd88 100644 --- a/src/Ganeti/Utils/Livelock.hs +++ b/src/Ganeti/Utils/Livelock.hs @@ -41,7 +41,7 @@ module Ganeti.Utils.Livelock import qualified Control.Exception as E import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath.Posix ((</>)) import System.IO @@ -59,7 +59,7 @@ type Livelock = FilePath -- | Appends the current time to the given prefix, creates -- the lockfile in the appropriate directory, and locks it. -- Returns its full path and the file's file descriptor. -mkLivelockFile :: (Error e, MonadError e m, MonadIO m) +mkLivelockFile :: (FromString e, MonadError e m, MonadIO m) => FilePath -> m (Fd, Livelock) mkLivelockFile prefix = do (TOD secs _) <- liftIO getClockTime diff --git a/src/Ganeti/Utils/Monad.hs b/src/Ganeti/Utils/Monad.hs index cd09a0d..cecaaf4 100644 --- a/src/Ganeti/Utils/Monad.hs +++ b/src/Ganeti/Utils/Monad.hs @@ -44,7 +44,7 @@ module Ganeti.Utils.Monad ) where import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Maybe -- | Retries the given action up to @n@ times. diff --git a/src/Ganeti/Utils/UniStd.hs b/src/Ganeti/Utils/UniStd.hs index c3453d9..6f301f2 100644 --- a/src/Ganeti/Utils/UniStd.hs +++ b/src/Ganeti/Utils/UniStd.hs @@ -54,7 +54,7 @@ foreign import ccall "fsync" fsync :: CInt -> IO CInt -- Because of a bug in GHC 7.6.3 (at least), calling 'hIsClosed' on a handle -- to get the file descriptor leaks memory. Therefore we open a given file -- just to sync it and close it again. -fsyncFile :: (Error e) => FilePath -> ResultT e IO () +fsyncFile :: (FromString e) => FilePath -> ResultT e IO () fsyncFile path = liftIO $ bracket (openFd path ReadOnly Nothing defaultFileFlags) closeFd callfsync where diff --git a/src/Ganeti/Utils/Validate.hs b/src/Ganeti/Utils/Validate.hs index 421f0c1..8dda1b0 100644 --- a/src/Ganeti/Utils/Validate.hs +++ b/src/Ganeti/Utils/Validate.hs @@ -54,13 +54,15 @@ module Ganeti.Utils.Validate import Control.Applicative import Control.Arrow import Control.Monad -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer import qualified Data.Foldable as F import Data.Functor.Identity import Data.List (intercalate) import Data.Sequence +import Ganeti.BasicTypes (FromString(..)) + -- | Monad for running validation checks. newtype ValidationMonadT m a = ValidationMonad { runValidationMonad :: WriterT (Seq String) m a } @@ -100,19 +102,19 @@ execValidate = runIdentity . execValidateT -- | A helper function for throwing an exception if a list of errors -- is non-empty. -throwIfErrors :: (MonadError e m, Error e) => (a, [String]) -> m a +throwIfErrors :: (MonadError e m, FromString e) => (a, [String]) -> m a throwIfErrors (x, []) = return x -throwIfErrors (_, es) = throwError (strMsg $ "Validation errors: " - ++ intercalate "; " es) +throwIfErrors (_, es) = throwError (mkFromString $ "Validation errors: " + ++ intercalate "; " es) -- | Runs a validation action and if there are errors, combine them -- into an exception. -evalValidate :: (MonadError e m, Error e) => ValidationMonad a -> m a +evalValidate :: (MonadError e m, FromString e) => ValidationMonad a -> m a evalValidate = throwIfErrors . runValidate -- | Runs a validation action and if there are errors, combine them -- into an exception. -evalValidateT :: (MonadError e m, Error e) => ValidationMonadT m a -> m a +evalValidateT :: (MonadError e m, FromString e) => ValidationMonadT m a -> m a evalValidateT k = runValidateT k >>= throwIfErrors -- | A typeclass for objects that can be validated. diff --git a/src/Ganeti/WConfd/Client.hs b/src/Ganeti/WConfd/Client.hs index 1e0be49..12bd69b 100644 --- a/src/Ganeti/WConfd/Client.hs +++ b/src/Ganeti/WConfd/Client.hs @@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay) import Control.Exception.Lifted (bracket) import Control.Monad (unless) import Control.Monad.Base -import Control.Monad.Error (MonadError) +import Control.Monad.Error.Class (MonadError) import Control.Monad.Trans.Control (MonadBaseControl) import Ganeti.BasicTypes (runResultT, GenericResult(..)) diff --git a/src/Ganeti/WConfd/ConfigModifications.hs b/src/Ganeti/WConfd/ConfigModifications.hs index fe09a9d..e476c30 100644 --- a/src/Ganeti/WConfd/ConfigModifications.hs +++ b/src/Ganeti/WConfd/ConfigModifications.hs @@ -47,7 +47,7 @@ import Control.Lens.Setter (Setter, (.~), (%~), (+~), over) import Control.Lens.Traversal (mapMOf) import Control.Lens.Type (Simple) import Control.Monad (unless, when, forM_, foldM, liftM, liftM2) -import Control.Monad.Error (throwError, MonadError) +import Control.Monad.Error.Class (throwError, MonadError) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State (StateT, get, put, modify, runStateT, execStateT) diff --git a/src/Ganeti/WConfd/ConfigVerify.hs b/src/Ganeti/WConfd/ConfigVerify.hs index 8b85027..a6d537b 100644 --- a/src/Ganeti/WConfd/ConfigVerify.hs +++ b/src/Ganeti/WConfd/ConfigVerify.hs @@ -39,7 +39,8 @@ module Ganeti.WConfd.ConfigVerify , verifyConfigErr ) where -import Control.Monad.Error +import Control.Monad (forM_) +import Control.Monad.Error.Class (MonadError(..)) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S diff --git a/src/Ganeti/WConfd/ConfigWriter.hs b/src/Ganeti/WConfd/ConfigWriter.hs index f3dd8dd..ba7a84d 100644 --- a/src/Ganeti/WConfd/ConfigWriter.hs +++ b/src/Ganeti/WConfd/ConfigWriter.hs @@ -45,8 +45,9 @@ module Ganeti.WConfd.ConfigWriter import Control.Applicative import Control.Monad.Base -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError) import qualified Control.Monad.State.Strict as S +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control import Data.Monoid diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs index 93bec0e..f028c84 100644 --- a/src/Ganeti/WConfd/Monad.hs +++ b/src/Ganeti/WConfd/Monad.hs @@ -74,7 +74,6 @@ import Control.Concurrent (forkIO, myThreadId) import Control.Exception.Lifted (bracket) import Control.Monad import Control.Monad.Base -import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control diff --git a/src/Ganeti/WConfd/Persistent.hs b/src/Ganeti/WConfd/Persistent.hs index 48b8330..dc0bc63 100644 --- a/src/Ganeti/WConfd/Persistent.hs +++ b/src/Ganeti/WConfd/Persistent.hs @@ -46,7 +46,7 @@ module Ganeti.WConfd.Persistent , persistentTempRes ) where -import Control.Monad.Error +import Control.Monad.Error.Class (catchError) import System.Directory (doesFileExist) import qualified Text.JSON as J diff --git a/src/Ganeti/WConfd/Server.hs b/src/Ganeti/WConfd/Server.hs index b226d09..1c2ef83 100644 --- a/src/Ganeti/WConfd/Server.hs +++ b/src/Ganeti/WConfd/Server.hs @@ -43,7 +43,6 @@ module Ganeti.WConfd.Server where import Control.Concurrent (forkIO) import Control.Exception import Control.Monad -import Control.Monad.Error import Ganeti.BasicTypes import qualified Ganeti.Constants as C @@ -88,8 +87,8 @@ prepMain _ _ = do conf_file <- Path.clusterConfFile dh <- toErrorBase - . withErrorT (strMsg . ("Initialization of the daemon failed" ++) - . formatError) $ do + . withErrorT (mkFromString . ("Initialization of the daemon failed" ++) + . formatError) $ do ents <- getEnts (cdata, cstat) <- loadConfigFromFile conf_file verifyConfigErr cdata diff --git a/src/Ganeti/WConfd/TempRes.hs b/src/Ganeti/WConfd/TempRes.hs index ef152ea..e478a3b 100644 --- a/src/Ganeti/WConfd/TempRes.hs +++ b/src/Ganeti/WConfd/TempRes.hs @@ -75,7 +75,7 @@ module Ganeti.WConfd.TempRes import Control.Applicative import Control.Lens.At -import Control.Monad.Error +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Trans.Maybe import qualified Data.Foldable as F -- 2.5.0.457.gab17608
