diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2016-03-03 Facundo Domínguez 0.6.1 + +* Implement MonadCatch, MonadThrow, MonadMask for Process. + 2016-02-18 Facundo Domínguez 0.6.0 * Have nsendRemote skip the transport for local communication. diff --git a/distributed-process.cabal b/distributed-process.cabal --- a/distributed-process.cabal +++ b/distributed-process.cabal @@ -1,5 +1,5 @@ Name: distributed-process -Version: 0.6.0 +Version: 0.6.1 Cabal-Version: >=1.8 Build-Type: Simple License: BSD3 @@ -54,7 +54,8 @@ ghc-prim >= 0.2 && < 0.5, distributed-static >= 0.2 && < 0.4, rank1dynamic >= 0.1 && < 0.4, - syb >= 0.3 && < 0.7 + syb >= 0.3 && < 0.7, + exceptions >= 0.5 Exposed-modules: Control.Distributed.Process, Control.Distributed.Process.Closure, Control.Distributed.Process.Debug, @@ -107,7 +108,7 @@ Type: exitcode-stdio-1.0 Build-Depends: base >= 4.4 && < 5, distributed-process, - network-transport-tcp >= 0.3 && < 0.5, + network-transport-tcp >= 0.3 && < 0.6, bytestring >= 0.9 && < 0.11, binary >= 0.6.3 && < 0.8 Main-Is: benchmarks/Throughput.hs @@ -117,7 +118,7 @@ Type: exitcode-stdio-1.0 Build-Depends: base >= 4.4 && < 5, distributed-process, - network-transport-tcp >= 0.3 && < 0.5, + network-transport-tcp >= 0.3 && < 0.6, bytestring >= 0.9 && < 0.11, binary >= 0.6.3 && < 0.8 Main-Is: benchmarks/Latency.hs @@ -127,7 +128,7 @@ Type: exitcode-stdio-1.0 Build-Depends: base >= 4.4 && < 5, distributed-process, - network-transport-tcp >= 0.3 && < 0.5, + network-transport-tcp >= 0.3 && < 0.6, bytestring >= 0.9 && < 0.11, binary >= 0.6.3 && < 0.8 Main-Is: benchmarks/Channels.hs @@ -137,7 +138,7 @@ Type: exitcode-stdio-1.0 Build-Depends: base >= 4.4 && < 5, distributed-process, - network-transport-tcp >= 0.3 && < 0.5, + network-transport-tcp >= 0.3 && < 0.6, bytestring >= 0.9 && < 0.11, binary >= 0.6.3 && < 0.8 Main-Is: benchmarks/Spawns.hs @@ -147,7 +148,7 @@ Type: exitcode-stdio-1.0 Build-Depends: base >= 4.4 && < 5, distributed-process, - network-transport-tcp >= 0.3 && < 0.5, + network-transport-tcp >= 0.3 && < 0.6, bytestring >= 0.9 && < 0.11, binary >= 0.6.3 && < 0.8 Main-Is: benchmarks/ProcessRing.hs diff --git a/src/Control/Distributed/Process.hs b/src/Control/Distributed/Process.hs --- a/src/Control/Distributed/Process.hs +++ b/src/Control/Distributed/Process.hs @@ -159,12 +159,8 @@ , reconnectPort ) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad.Reader (ask) import Control.Concurrent.MVar ( MVar @@ -316,8 +312,14 @@ , spawnSupervised , call ) -import Control.Exception (SomeException, throw) +import qualified Control.Monad.Catch as Catch +#if MIN_VERSION_base(4,6,0) +import Prelude +#else +import Prelude hiding (catch) +#endif + -- INTERNAL NOTES -- -- 1. 'send' never fails. If you want to know that the remote process received @@ -413,9 +415,9 @@ -- or duplicate messages sent to the isolated process after it exits. -- Silently dropping messages may not always be the best approach. callLocal :: Process a -> Process a -callLocal proc = mask $ \release -> do - mv <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a)) - child <- spawnLocal $ try (release proc) >>= liftIO . putMVar mv - rs <- liftIO (takeMVar mv) `onException` +callLocal proc = Catch.mask $ \release -> do + mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a)) + child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv + rs <- liftIO (takeMVar mv) `Catch.onException` (kill child "exception in parent process" >> liftIO (takeMVar mv)) - either throw return rs + either Catch.throwM return rs diff --git a/src/Control/Distributed/Process/Internal/Primitives.hs b/src/Control/Distributed/Process/Internal/Primitives.hs --- a/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/src/Control/Distributed/Process/Internal/Primitives.hs @@ -137,9 +137,14 @@ import Control.Monad (when) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) -import Control.Exception (Exception(..), throw, throwIO, SomeException) -import qualified Control.Exception as Ex (catch, mask, mask_, try) +import Control.Monad.Catch + ( Exception + , SomeException + , throwM + , fromException + ) +import qualified Control.Monad.Catch as Catch +import Control.Applicative import Control.Distributed.Process.Internal.StrictMVar ( StrictMVar , modifyMVar @@ -203,7 +208,6 @@ , isEncoded , createMessage , createUnencodedMessage - , runLocalProcess , ImplicitReconnect( NoImplicitReconnect) , LocalProcessState , LocalSendPortId @@ -227,6 +231,7 @@ , readTQueue , mkWeakTQueue ) +import Prelude import Unsafe.Coerce @@ -699,7 +704,7 @@ -- | Terminate immediately (throws a ProcessTerminationException) terminate :: Process a -terminate = liftIO $ throwIO ProcessTerminationException +terminate = throwM ProcessTerminationException -- [Issue #110] -- | Die immediately - throws a 'ProcessExitException' with the given @reason@. @@ -709,7 +714,7 @@ -- could be decoded by a handler passed to 'catchExit', re-thrown or even -- passed to another process via the tracing mechanism. pid <- getSelfPid - liftIO $ throwIO (ProcessExitException pid (createMessage reason)) + throwM (ProcessExitException pid (createMessage reason)) -- | Forceful request to kill a process. Where 'exit' provides an exception -- that can be caught and handled, 'kill' throws an unexposed exception type @@ -742,12 +747,12 @@ => Process b -> (ProcessId -> a -> Process b) -> Process b -catchExit act exitHandler = catch act handleExit +catchExit act exitHandler = Catch.catch act handleExit where handleExit ex@(ProcessExitException from msg) = if messageFingerprint msg == fingerprint (undefined :: a) then exitHandler from decoded - else liftIO $ throwIO ex + else throwM ex where decoded :: a -- Make sure the value is fully decoded so that we don't hang to @@ -766,12 +771,12 @@ catchesExit :: Process b -> [(ProcessId -> Message -> (Process (Maybe b)))] -> Process b -catchesExit act handlers = catch act ((flip handleExit) handlers) +catchesExit act handlers = Catch.catch act ((flip handleExit) handlers) where handleExit :: ProcessExitException -> [(ProcessId -> Message -> Process (Maybe b))] -> Process b - handleExit ex [] = liftIO $ throwIO ex + handleExit ex [] = throwM ex handleExit ex@(ProcessExitException from msg) (h:hs) = do r <- h from msg case r of @@ -936,56 +941,43 @@ -- | Lift 'Control.Exception.catch' catch :: Exception e => Process a -> (e -> Process a) -> Process a -catch p h = do - lproc <- ask - liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h) +catch = Catch.catch +{-# DEPRECATED catch "Use Control.Monad.Catch.catch instead" #-} -- | Lift 'Control.Exception.try' try :: Exception e => Process a -> Process (Either e a) -try p = do - lproc <- ask - liftIO $ Ex.try (runLocalProcess lproc p) +try = Catch.try +{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-} -- | Lift 'Control.Exception.mask' mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b -mask p = do - lproc <- ask - liftIO $ Ex.mask $ \restore -> - runLocalProcess lproc (p (liftRestore restore)) - where - liftRestore :: (forall a. IO a -> IO a) - -> (forall a. Process a -> Process a) - liftRestore restoreIO = \p2 -> do - ourLocalProc <- ask - liftIO $ restoreIO $ runLocalProcess ourLocalProc p2 +mask = Catch.mask +{-# DEPRECATED mask "Use Control.Monad.Catch.mask_ instead" #-} -- | Lift 'Control.Exception.mask_' mask_ :: Process a -> Process a -mask_ p = do - lproc <- ask - liftIO $ Ex.mask_ $ runLocalProcess lproc p +mask_ = Catch.mask_ +{-# DEPRECATED mask_ "Use Control.Monad.Catch.mask_ instead" #-} -- | Lift 'Control.Exception.onException' onException :: Process a -> Process b -> Process a -onException p what = p `catch` \e -> do _ <- what - liftIO $ throwIO (e :: SomeException) +onException = Catch.onException +{-# DEPRECATED onException "Use Control.Monad.Catch.onException instead" #-} -- | Lift 'Control.Exception.bracket' bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c -bracket before after thing = - mask $ \restore -> do - a <- before - r <- restore (thing a) `onException` after a - _ <- after a - return r +bracket = Catch.bracket +{-# DEPRECATED bracket "Use Control.Monad.Catch.bracket instead" #-} -- | Lift 'Control.Exception.bracket_' bracket_ :: Process a -> Process b -> Process c -> Process c -bracket_ before after thing = bracket before (const after) (const thing) +bracket_ = Catch.bracket_ +{-# DEPRECATED bracket_ "Use Control.Monad.Catch.bracket_ instead" #-} -- | Lift 'Control.Exception.finally' finally :: Process a -> Process b -> Process a -finally a sequel = bracket_ (return ()) sequel a +finally = Catch.finally +{-# DEPRECATED finally "Use Control.Monad.Catch.finally instead" #-} -- | You need this when using 'catches' data Handler a = forall e . Exception e => Handler (e -> Process a) @@ -995,10 +987,10 @@ -- | Lift 'Control.Exception.catches' catches :: Process a -> [Handler a] -> Process a -catches proc handlers = proc `catch` catchesHandler handlers +catches proc handlers = proc `Catch.catch` catchesHandler handlers catchesHandler :: [Handler a] -> SomeException -> Process a -catchesHandler handlers e = foldr tryHandler (throw e) handlers +catchesHandler handlers e = foldr tryHandler (throwM e) handlers where tryHandler (Handler handler) res = case fromException e of Just e' -> handler e' @@ -1138,7 +1130,7 @@ handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process () handleRegistrationReply label ok owner = when (not ok) $ - liftIO $ throwIO $ ProcessRegistrationException label owner + throwM $ ProcessRegistrationException label owner -- | Remove a process from a remote registry (asynchronous). -- diff --git a/src/Control/Distributed/Process/Internal/Types.hs b/src/Control/Distributed/Process/Internal/Types.hs --- a/src/Control/Distributed/Process/Internal/Types.hs +++ b/src/Control/Distributed/Process/Internal/Types.hs @@ -4,6 +4,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} -- | Types used throughout the Cloud Haskell framework -- @@ -112,11 +115,12 @@ import Control.Concurrent.Chan (Chan) import Control.Concurrent.STM (STM) import Control.Concurrent.STM.TChan (TChan) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..)) import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection) -import Control.Applicative (Applicative, Alternative, (<$>), (<*>)) +import Control.Applicative import Control.Monad.Fix (MonadFix) import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Distributed.Process.Serializable ( Fingerprint , Serializable @@ -139,6 +143,7 @@ import Data.Hashable import GHC.Generics +import Prelude -------------------------------------------------------------------------------- -- Node and process identifiers -- @@ -345,7 +350,42 @@ newtype Process a = Process { unProcess :: ReaderT LocalProcess IO a } - deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative, MonadFix) + deriving ( Applicative + , Functor + , Monad + , MonadFix + , MonadIO + , MonadReader LocalProcess + , Typeable + ) + +instance MonadThrow Process where + throwM = liftIO . throwIO +instance MonadCatch Process where + catch p h = do + lproc <- ask + liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h) +instance MonadMask Process where + mask p = do + lproc <- ask + liftIO $ mask $ \restore -> + runLocalProcess lproc (p (liftRestore restore)) + where + liftRestore :: (forall a. IO a -> IO a) + -> (forall a. Process a -> Process a) + liftRestore restoreIO = \p2 -> do + ourLocalProc <- ask + liftIO $ restoreIO $ runLocalProcess ourLocalProc p2 + uninterruptibleMask p = do + lproc <- ask + liftIO $ uninterruptibleMask $ \restore -> + runLocalProcess lproc (p (liftRestore restore)) + where + liftRestore :: (forall a. IO a -> IO a) + -> (forall a. Process a -> Process a) + liftRestore restoreIO = \p2 -> do + ourLocalProc <- ask + liftIO $ restoreIO $ runLocalProcess ourLocalProc p2 -------------------------------------------------------------------------------- -- Typed channels -- diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs --- a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs +++ b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs @@ -11,7 +11,7 @@ , eventLogTracer ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Concurrent.Chan (writeChan) import Control.Concurrent.MVar ( MVar @@ -21,9 +21,7 @@ ( CQueue ) import Control.Distributed.Process.Internal.Primitives - ( catch - , finally - , die + ( die , receiveWait , forward , sendChan @@ -63,6 +61,10 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask) +import Control.Monad.Catch + ( catch + , finally + ) import Data.Set (Set) import qualified Data.Set as Set @@ -73,6 +75,7 @@ import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) import Debug.Trace (traceEventIO) +import Prelude #if ! MIN_VERSION_base(4,6,0) import Prelude hiding (catch)