@@ -21,6 +21,7 @@ module Control.Distributed.Process.Internal.Primitives
2121 , matchUnknown
2222 , AbstractMessage(..)
2323 , matchAny
24+ , matchAnyIf
2425 , matchChan
2526 -- * Process management
2627 , terminate
@@ -29,6 +30,9 @@ module Control.Distributed.Process.Internal.Primitives
2930 , kill
3031 , exit
3132 , catchExit
33+ , catchesExit
34+ -- keep the exception constructor hidden, so that handling exit
35+ -- reasons must take place via the 'catchExit' family of primitives
3236 , ProcessExitException()
3337 , getSelfPid
3438 , getSelfNode
@@ -311,24 +315,68 @@ matchIf c p = Match $ MatchMsg $ \msg ->
311315 !decoded = decode (messageEncoding msg)
312316 _ -> Nothing
313317
318+-- | Represents a received message and provides two basic operations on it.
314319data AbstractMessage = AbstractMessage {
315− forward :: ProcessId -> Process ()
320+ forward :: ProcessId -> Process () -- ^ forward the message to @ProcessId@
321+ , maybeHandleMessage :: forall a b. (Serializable a)
322+ => (a -> Process b) -> Process (Maybe b) {- ^ Handle the message.
323+ If the type of the message matches the type of the first argument to
324+ the supplied expression, then the expression will be evaluated against
325+ it. If this runtime type checking fails, then @Nothing@ will be returned
326+ to indicate the fact. If the check succeeds and evaluation proceeds
327+ however, the resulting value with be wrapped with @Just@.
328+ -}
316329 }
317330
318−-- | Match against an arbitrary message
331+-- | Match against an arbitrary message. 'matchAny' removes the first available
332+-- message from the process mailbox, and via the 'AbstractMessage' type,
333+-- supports forwarding /or/ handling the message /if/ it is of the correct
334+-- type. If /not/ of the right type, then the 'AbstractMessage'
335+-- @maybeHandleMessage@ function will not evaluate the supplied expression,
336+-- /but/ the message will still have been removed from the process mailbox!
337+--
319338matchAny :: forall b. (AbstractMessage -> Process b) -> Match b
320−matchAny p = Match $ MatchMsg $ Just . p . abstract
321− where
322− abstract :: Message -> AbstractMessage
323− abstract msg = AbstractMessage {
324− forward = \them -> do
325− proc <- ask
326− liftIO $ sendPayload (processNode proc)
327− (ProcessIdentifier (processId proc))
328− (ProcessIdentifier them)
329− NoImplicitReconnect
330− (messageToPayload msg)
331− }
339+matchAny p = Match $ MatchMsg $ Just . p . abstract
340+
341+-- | Match against an arbitrary message. 'matchAnyIf' will /only/ remove the
342+-- message from the process mailbox, /if/ the supplied condition matches. The
343+-- success (or failure) of runtime type checks in @maybeHandleMessage@ does not
344+-- count here, i.e., if the condition evaluates to @True@ then the message will
345+-- be removed from the process mailbox and decoded, but that does /not/
346+-- guarantee that an expression passed to @maybeHandleMessage@ will pass the
347+-- runtime type checks and therefore be evaluated. If the types do not match
348+-- up, then @maybeHandleMessage@ returns 'Nothing'.
349+matchAnyIf :: forall a b. (Serializable a)
350+ => (a -> Bool)
351+ -> (AbstractMessage -> Process b)
352+ -> Match b
353+matchAnyIf c p = Match $ MatchMsg $ \msg ->
354+ case messageFingerprint msg == fingerprint (undefined :: a) of
355+ True | c decoded -> Just (p (abstract msg))
356+ where
357+ decoded :: a
358+ -- Make sure the value is fully decoded so that we don't hang to
359+ -- bytestrings when the calling process doesn't evaluate immediately
360+ !decoded = decode (messageEncoding msg)
361+ _ -> Nothing
362+
363+abstract :: Message -> AbstractMessage
364+abstract msg = AbstractMessage {
365+ forward = \them -> do
366+ proc <- ask
367+ liftIO $ sendPayload (processNode proc)
368+ (ProcessIdentifier (processId proc))
369+ (ProcessIdentifier them)
370+ NoImplicitReconnect
371+ (messageToPayload msg)
372+ , maybeHandleMessage = \(proc :: (a -> Process b)) -> do
373+ case messageFingerprint msg == fingerprint (undefined :: a) of
374+ True -> do { r <- proc (decoded :: a); return (Just r) }
375+ where
376+ decoded :: a
377+ !decoded = decode (messageEncoding msg)
378+ _ -> return Nothing
379+ }
332380
333381-- | Remove any message from the queue
334382matchUnknown :: Process b -> Match b
@@ -349,13 +397,15 @@ terminate :: Process a
349397terminate = liftIO $ throwIO ProcessTerminationException
350398
351399-- [Issue #110]
352−-- | Die immediately - throws a 'ProcessExitException' with the given @reason@
400+-- | Die immediately - throws a 'ProcessExitException' with the given @reason@.
353401die :: Serializable a => a -> Process b
354402die reason = do
355403 pid <- getSelfPid
356404 liftIO $ throwIO (ProcessExitException pid (createMessage reason))
357405
358−-- | Forceful request to kill a process
406+-- | Forceful request to kill a process. Where 'exit' provides an exception
407+-- that can be caught and handled, 'kill' throws an unexposed exception type
408+-- which cannot be handled explicitly (by type).
359409kill :: ProcessId -> String -> Process ()
360410-- NOTE: We send the message to our local node controller, which will then
361411-- forward it to a remote node controller (if applicable). Sending it directly
@@ -363,7 +413,9 @@ kill :: ProcessId -> String -> Process ()
363413-- 'monitor' or 'link' request.
364414kill them reason = sendCtrlMsg Nothing (Kill them reason)
365415
366−-- | Graceful request to exit a process
416+-- | Graceful request to exit a process. Throws 'ProcessExitException' with the
417+-- supplied @reason@ encoded as a message. Any /exit signal/ raised in this
418+-- manner can be handled using the 'catchExit' family of functions.
367419exit :: Serializable a => ProcessId -> a -> Process ()
368420-- NOTE: We send the message to our local node controller, which will then
369421-- forward it to a remote node controller (if applicable). Sending it directly
@@ -371,7 +423,13 @@ exit :: Serializable a => ProcessId -> a -> Process ()
371423-- 'monitor' or 'link' request.
372424exit them reason = sendCtrlMsg Nothing (Exit them (createMessage reason))
373425
374−-- | Catches ProcessExitException
426+-- | Catches 'ProcessExitException'. The handler will not be applied unless its
427+-- type matches the encoded data stored in the exception (see the /reason/
428+-- argument given to the 'exit' primitive). If the handler cannot be applied,
429+-- the exception will be re-thrown.
430+--
431+-- To handle 'ProcessExitException' without regard for /reason/, see 'catch'.
432+-- To handle multiple /reasons/ of differing types, see 'catchesExit'.
375433catchExit :: forall a b . (Show a, Serializable a)
376434 => Process b
377435 -> (ProcessId -> a -> Process b)
@@ -388,6 +446,29 @@ catchExit act exitHandler = catch act handleExit
388446 -- bytestrings if the caller doesn't use the value immediately
389447 !decoded = decode (messageEncoding msg)
390448
449+-- | As 'Control.Exception.catches' but allows for multiple handlers. Because
450+-- 'ProcessExitException' stores the exit @reason@ as a typed, encoded message,
451+-- a handler must accept an input of the expected type. In order to handle
452+-- a list of potentially different handlers (and therefore input types), a
453+-- handler passed to 'catchesExit' must accept 'AbstractMessage' and return
454+-- @Maybe@ (i.e., @Just p@ if it handled the exit reason, otherwise @Nothing@).
455+--
456+-- See 'maybeHandleMessage' and 'AsbtractMessage' for more details.
457+catchesExit :: Process b
458+ -> [(ProcessId -> AbstractMessage -> (Process (Maybe b)))]
459+ -> Process b
460+catchesExit act handlers = catch act ((flip handleExit) handlers)
461+ where
462+ handleExit :: ProcessExitException
463+ -> [(ProcessId -> AbstractMessage -> Process (Maybe b))]
464+ -> Process b
465+ handleExit ex [] = liftIO $ throwIO ex
466+ handleExit ex@(ProcessExitException from msg) (h:hs) = do
467+ r <- h from (abstract msg)
468+ case r of
469+ Nothing -> handleExit ex hs
470+ Just p -> return p
471+
391472-- | Our own process ID
392473getSelfPid :: Process ProcessId
393474getSelfPid = processId <$> ask