Permalink
Browse files

introduce a 'catchesExit' primitive, document "exit signals", export API

  • Loading branch information...
1 parent 8af66f4 commit e2cd2d5728d6ed84c2fcd1134eb73f12fea07a8f @hyperthunk hyperthunk committed Jan 18, 2013
@@ -5,7 +5,7 @@
-- Peyton Jones
-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
-- although some of the details are different. The precise message passing
--- semantics are based on /A unified semantics for future Erlang/ by Hans
+-- semantics are based on /A unified semantics for future Erlang/ by Hans
-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.
module Control.Distributed.Process
( -- * Basic types
@@ -49,6 +49,7 @@ module Control.Distributed.Process
, kill
, exit
, catchExit
+ , catchesExit
, ProcessTerminationException(..)
, ProcessRegistrationException(..)
, SpawnRef
@@ -201,6 +202,7 @@ import Control.Distributed.Process.Internal.Primitives
, die
, exit
, catchExit
+ , catchesExit
, kill
, getSelfPid
, getSelfNode
@@ -363,7 +365,11 @@ spawnMonitor nid proc = do
-- "Control.Distributed.Process.Closure".
--
-- See also 'spawn'.
-call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
+call :: Serializable a
+ => Static (SerializableDict a)
+ -> NodeId
+ -> Closure (Process a)
+ -> Process a
call dict nid proc = do
us <- getSelfPid
(pid, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)
@@ -30,6 +30,9 @@ module Control.Distributed.Process.Internal.Primitives
, kill
, exit
, catchExit
+ , catchesExit
+ -- keep the exception constructor hidden, so that handling exit
+ -- reasons must take place via the 'catchExit' family of primitives
, ProcessExitException()
, getSelfPid
, getSelfNode
@@ -312,11 +315,17 @@ matchIf c p = Match $ MatchMsg $ \msg ->
!decoded = decode (messageEncoding msg)
_ -> Nothing
--- | Represents a received message and provides two operations on it.
+-- | Represents a received message and provides two basic operations on it.
data AbstractMessage = AbstractMessage {
forward :: ProcessId -> Process () -- ^ forward the message to @ProcessId@
, maybeHandleMessage :: forall a b. (Serializable a)
- => (a -> Process b) -> Process (Maybe b) -- ^ handle the message if it is of the given type
+ => (a -> Process b) -> Process (Maybe b) {- ^ Handle the message.
+ If the type of the message matches the type of the first argument to
+ the supplied expression, then the expression will be evaluated against
+ it. If this runtime type checking fails, then @Nothing@ will be returned
+ to indicate the fact. If the check succeeds and evaluation proceeds
+ however, the resulting value with be wrapped with @Just@.
+ -}
}
-- | Match against an arbitrary message. 'matchAny' removes the first available
@@ -388,29 +397,39 @@ terminate :: Process a
terminate = liftIO $ throwIO ProcessTerminationException
-- [Issue #110]
--- | Die immediately - throws a 'ProcessExitException' with the given @reason@
+-- | Die immediately - throws a 'ProcessExitException' with the given @reason@.
die :: Serializable a => a -> Process b
die reason = do
pid <- getSelfPid
liftIO $ throwIO (ProcessExitException pid (createMessage reason))
--- | Forceful request to kill a process
+-- | Forceful request to kill a process. Where 'exit' provides an exception
+-- that can be caught and handled, 'kill' throws an unexposed exception type
+-- which cannot be handled explicitly (by type).
kill :: ProcessId -> String -> Process ()
-- NOTE: We send the message to our local node controller, which will then
-- forward it to a remote node controller (if applicable). Sending it directly
-- to a remote node controller means that that the message may overtake a
-- 'monitor' or 'link' request.
kill them reason = sendCtrlMsg Nothing (Kill them reason)
--- | Graceful request to exit a process
+-- | Graceful request to exit a process. Throws 'ProcessExitException' with the
+-- supplied @reason@ encoded as a message. Any /exit signal/ raised in this
+-- manner can be handled using the 'catchExit' family of functions.
exit :: Serializable a => ProcessId -> a -> Process ()
-- NOTE: We send the message to our local node controller, which will then
-- forward it to a remote node controller (if applicable). Sending it directly
-- to a remote node controller means that that the message may overtake a
-- 'monitor' or 'link' request.
exit them reason = sendCtrlMsg Nothing (Exit them (createMessage reason))
--- | Catches ProcessExitException
+-- | Catches 'ProcessExitException'. The handler will not be applied unless its
+-- type matches the encoded data stored in the exception (see the /reason/
+-- argument given to the 'exit' primitive). If the handler cannot be applied,
+-- the exception will be re-thrown.
+--
+-- To handle 'ProcessExitException' without regard for /reason/, see 'catch'.
+-- To handle multiple /reasons/ of differing types, see 'catchesExit'.
catchExit :: forall a b . (Show a, Serializable a)
=> Process b
-> (ProcessId -> a -> Process b)
@@ -427,6 +446,29 @@ catchExit act exitHandler = catch act handleExit
-- bytestrings if the caller doesn't use the value immediately
!decoded = decode (messageEncoding msg)
+-- | As 'Control.Exception.catches' but allows for multiple handlers. Because
+-- 'ProcessExitException' stores the exit @reason@ as a typed, encoded message,
+-- a handler must accept an input of the expected type. In order to handle
+-- a list of potentially different handlers (and therefore input types), a
+-- handler passed to 'catchesExit' must accept 'AbstractMessage' and return
+-- @Maybe@ (i.e., @Just p@ if it handled the exit reason, otherwise @Nothing@).
+--
+-- See 'maybeHandleMessage' and 'AsbtractMessage' for more details.
+catchesExit :: Process b
+ -> [(ProcessId -> AbstractMessage -> (Process (Maybe b)))]
+ -> Process b
+catchesExit act handlers = catch act ((flip handleExit) handlers)
+ where
+ handleExit :: ProcessExitException
+ -> [(ProcessId -> AbstractMessage -> Process (Maybe b))]
+ -> Process b
+ handleExit ex [] = liftIO $ throwIO ex
+ handleExit ex@(ProcessExitException from msg) (h:hs) = do
+ r <- h from (abstract msg)
+ case r of
+ Nothing -> handleExit ex hs
+ Just p -> return p
+
-- | Our own process ID
getSelfPid :: Process ProcessId
getSelfPid = processId <$> ask
@@ -1009,6 +1009,22 @@ testKillRemote transport = do
takeMVar done
+testCatchesExit :: NT.Transport -> Assertion
+testCatchesExit transport = do
+ localNode <- newLocalNode transport initRemoteTable
+ done <- newEmptyMVar
+
+ _ <- forkProcess localNode $ do
+ (die ("foobar", 123 :: Int))
+ `catchesExit` [
+ (\_ m -> maybeHandleMessage m (\(_ :: String) -> return ()))
+ , (\_ m -> maybeHandleMessage m (\(_ :: Maybe Int) -> return ()))
+ , (\_ m -> maybeHandleMessage m (\(_ :: String, _ :: Int)
+ -> (liftIO $ putMVar done ()) >> return ()))
+ ]
+
+ takeMVar done
+
testDie :: NT.Transport -> Assertion
testDie transport = do
localNode <- newLocalNode transport initRemoteTable
@@ -1111,6 +1127,7 @@ tests (transport, transportInternals) = [
, testCase "KillRemote" (testKillRemote transport)
, testCase "Die" (testDie transport)
, testCase "PrettyExit" (testPrettyExit transport)
+ , testCase "CatchesExit" (testCatchesExit transport)
, testCase "ExitLocal" (testExitLocal transport)
, testCase "ExitRemote" (testExitRemote transport)
]

0 comments on commit e2cd2d5

Please sign in to comment.