@@ -19,10 +19,15 @@ module Control.Distributed.Process.Internal.Primitives
1919 , match
2020 , matchIf
2121 , matchUnknown
22− , AbstractMessage(..)
2322 , matchAny
2423 , matchAnyIf
2524 , matchChan
25+ , matchMessage
26+ , matchMessageIf
27+ , wrapMessage
28+ , unwrapMessage
29+ , handleMessage
30+ , forward
2631 -- * Process management
2732 , terminate
2833 , ProcessTerminationException(..)
@@ -320,44 +325,108 @@ matchIf c p = Match $ MatchMsg $ \msg ->
320325 !decoded = decode (messageEncoding msg)
321326 _ -> Nothing
322327
323−-- | Represents a received message and provides two basic operations on it.
324−data AbstractMessage = AbstractMessage {
325− forward :: ProcessId -> Process () -- ^ forward the message to @ProcessId@
326− , maybeHandleMessage :: forall a b. (Serializable a)
327− => (a -> Process b) -> Process (Maybe b) {- ^ Handle the message.
328− If the type of the message matches the type of the first argument to
329− the supplied expression, then the expression will be evaluated against
330− it. If this runtime type checking fails, then @Nothing@ will be returned
331− to indicate the fact. If the check succeeds and evaluation proceeds
332− however, the resulting value with be wrapped with @Just@.
333− -}
334− }
328+-- | Match against any message, regardless of the underlying (contained) type
329+matchMessage :: (Message -> Process Message) -> Match Message
330+matchMessage p = Match $ MatchMsg $ \msg -> Just (p msg)
331+
332+-- | Match against any message (regardless of underlying type) that satisfies a predicate
333+matchMessageIf :: (Message -> Bool) -> (Message -> Process Message) -> Match Message
334+matchMessageIf c p = Match $ MatchMsg $ \msg ->
335+ case (c msg) of
336+ True -> Just (p msg)
337+ False -> Nothing
338+
339+-- | Forward a raw 'Message' to the given 'ProcessId'.
340+forward :: Message -> ProcessId -> Process ()
341+forward msg them = do
342+ proc <- ask
343+ liftIO $ sendPayload (processNode proc)
344+ (ProcessIdentifier (processId proc))
345+ (ProcessIdentifier them)
346+ NoImplicitReconnect
347+ (messageToPayload msg)
348+
349+-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are
350+-- 'Serializable' - like the datum they contain - but remember that deserializing
351+-- a 'Message' will yield a 'Message', not the type within it! To obtain the
352+-- wrapped datum, use 'unwrapMessage' or 'handleMessage' with a specific type.
353+--
354+-- @
355+-- do
356+-- self <- getSelfPid
357+-- send self (wrapMessage "blah")
358+-- Nothing <- expectTimeout 1000000 :: Process (Maybe String)
359+-- (Just m) <- expectTimeout 1000000 :: Process (Maybe Message)
360+-- "blah" <- unwrapMessage m :: Process (Maybe String)
361+-- @
362+--
363+wrapMessage :: Serializable a => a -> Message
364+wrapMessage = createMessage
365+
366+-- | Attempt to unwrap a raw 'Message'.
367+-- If the type of the decoded message payload matches the expected type, the
368+-- value will be returned with @Just@, otherwise @Nothing@ indicates the types
369+-- do not match.
370+--
371+-- This expression, for example, will evaluate to @Nothing@
372+-- > unwrapMessage (wrapMessage "foobar") :: Process (Maybe Int)
373+--
374+-- Whereas this expression, will yield @Just "foo"@
375+-- > unwrapMessage (wrapMessage "foo") :: Process (Maybe String)
376+--
377+unwrapMessage :: forall a. Serializable a => Message -> Process (Maybe a)
378+unwrapMessage msg =
379+ case messageFingerprint msg == fingerprint (undefined :: a) of
380+ True -> return (Just (decoded))
381+ where
382+ decoded :: a
383+ -- Make sure the value is fully decoded so that we don't hang to
384+ -- bytestrings when the calling process doesn't evaluate immediately
385+ !decoded = decode (messageEncoding msg)
386+ _ -> return Nothing
387+
388+-- | Attempt to handle a raw 'Message'.
389+-- If the type of the message matches the type of the first argument to
390+-- the supplied expression, then the message will be decoded and the expression
391+-- evaluated against its value. If this runtime type checking fails however,
392+-- @Nothing@ will be returned to indicate the fact. If the check succeeds and
393+-- evaluation proceeds, the resulting value with be wrapped with @Just@.
394+--
395+-- Intended for use in `catchesExit` and `matchAny` primitives.
396+--
397+handleMessage :: forall a b. (Serializable a)
398+ => Message -> (a -> Process b) -> Process (Maybe b)
399+handleMessage msg proc = do
400+ case messageFingerprint msg == fingerprint (undefined :: a) of
401+ True -> do { r <- proc (decoded :: a); return (Just r) }
402+ where
403+ decoded :: a
404+ !decoded = decode (messageEncoding msg)
405+ _ -> return Nothing
335406
336407-- | Match against an arbitrary message. 'matchAny' removes the first available
337−-- message from the process mailbox, and via the 'AbstractMessage' type,
338−-- supports forwarding /or/ handling the message /if/ it is of the correct
339−-- type. If /not/ of the right type, then the 'AbstractMessage'
340−-- @maybeHandleMessage@ function will not evaluate the supplied expression,
341−-- /but/ the message will still have been removed from the process mailbox!
342−--
343−matchAny :: forall b. (AbstractMessage -> Process b) -> Match b
344−matchAny p = Match $ MatchMsg $ Just . p . abstract
345−
346−-- | Match against an arbitrary message. 'matchAnyIf' will /only/ remove the
347−-- message from the process mailbox, /if/ the supplied condition matches. The
348−-- success (or failure) of runtime type checks in @maybeHandleMessage@ does not
349−-- count here, i.e., if the condition evaluates to @True@ then the message will
408+-- message from the process mailbox. To handle arbitrary /raw/ messages once
409+-- removed from the mailbox, see 'handleMessage' and 'unwrapMessage'.
410+--
411+matchAny :: forall b. (Message -> Process b) -> Match b
412+matchAny p = Match $ MatchMsg $ \msg -> Just (p msg)
413+
414+-- | Match against an arbitrary message. Intended for use with 'handleMessage'
415+-- and 'unwrapMessage', this function /only/ removes a message from the process
416+-- mailbox, /if/ the supplied condition matches. The success (or failure) of
417+-- runtime type checks deferred to @handleMessage@ and friends is irrelevant
418+-- here, i.e., if the condition evaluates to @True@ then the message will
350419-- be removed from the process mailbox and decoded, but that does /not/
351−-- guarantee that an expression passed to @maybeHandleMessage@ will pass the
352−-- runtime type checks and therefore be evaluated. If the types do not match
353−-- up, then @maybeHandleMessage@ returns 'Nothing'.
420+-- guarantee that an expression passed to @handleMessage@ will pass the
421+-- runtime type checks and therefore be evaluated.
422+--
354423matchAnyIf :: forall a b. (Serializable a)
355424 => (a -> Bool)
356− -> (AbstractMessage -> Process b)
425+ -> (Message -> Process b)
357426 -> Match b
358427matchAnyIf c p = Match $ MatchMsg $ \msg ->
359428 case messageFingerprint msg == fingerprint (undefined :: a) of
360− True | c decoded -> Just (p (abstract msg))
429+ True | c decoded -> Just (p msg)
361430 where
362431 decoded :: a
363432 -- Make sure the value is fully decoded so that we don't hang to
@@ -365,24 +434,6 @@ matchAnyIf c p = Match $ MatchMsg $ \msg ->
365434 !decoded = decode (messageEncoding msg)
366435 _ -> Nothing
367436
368−abstract :: Message -> AbstractMessage
369−abstract msg = AbstractMessage {
370− forward = \them -> do
371− proc <- ask
372− liftIO $ sendPayload (processNode proc)
373− (ProcessIdentifier (processId proc))
374− (ProcessIdentifier them)
375− NoImplicitReconnect
376− (messageToPayload msg)
377− , maybeHandleMessage = \(proc :: (a -> Process b)) -> do
378− case messageFingerprint msg == fingerprint (undefined :: a) of
379− True -> do { r <- proc (decoded :: a); return (Just r) }
380− where
381− decoded :: a
382− !decoded = decode (messageEncoding msg)
383− _ -> return Nothing
384− }
385−
386437-- | Remove any message from the queue
387438matchUnknown :: Process b -> Match b
388439matchUnknown p = Match $ MatchMsg (const (Just p))
@@ -461,16 +512,16 @@ catchExit act exitHandler = catch act handleExit
461512--
462513-- See 'maybeHandleMessage' and 'AsbtractMessage' for more details.
463514catchesExit :: Process b
464− -> [(ProcessId -> AbstractMessage -> (Process (Maybe b)))]
515+ -> [(ProcessId -> Message -> (Process (Maybe b)))]
465516 -> Process b
466517catchesExit act handlers = catch act ((flip handleExit) handlers)
467518 where
468519 handleExit :: ProcessExitException
469− -> [(ProcessId -> AbstractMessage -> Process (Maybe b))]
520+ -> [(ProcessId -> Message -> Process (Maybe b))]
470521 -> Process b
471522 handleExit ex [] = liftIO $ throwIO ex
472523 handleExit ex@(ProcessExitException from msg) (h:hs) = do
473− r <- h from (abstract msg)
524+ r <- h from msg
474525 case r of
475526 Nothing -> handleExit ex hs
476527 Just p -> return p