From 49695f71e25218db18514a0a70624cbfaccc748f Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <aenor.realm@gmail.com>
Date: Tue, 8 Mar 2016 19:36:53 +0300
Subject: [PATCH 01/50] Move state argument into CallHandler-like position.

---
 .../Process/ManagedProcess/Server.hs          | 30 +++++++++----------
 1 file changed, 15 insertions(+), 15 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index e33ae6e..f007636 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -309,7 +309,7 @@ handleCallFromIf_ c h =
 -- worker (or stash it away itself) and return 'noReply'.
 --
 handleCallFrom :: forall s a b . (Serializable a, Serializable b)
-           => (s -> CallRef b -> a -> Process (ProcessReply b s))
+           => (CallRef b -> s -> a -> Process (ProcessReply b s))
            -> Dispatcher s
 handleCallFrom = handleCallFromIf $ state (const True)
 
@@ -318,7 +318,7 @@ handleCallFrom = handleCallFromIf $ state (const True)
 --
 handleCallFromIf :: forall s a b . (Serializable a, Serializable b)
     => Condition s a -- ^ predicate that must be satisfied for the handler to run
-    -> (s -> CallRef b -> a -> Process (ProcessReply b s))
+    -> (CallRef b -> s -> a -> Process (ProcessReply b s))
         -- ^ a reply yielding function over the process state, sender and input message
     -> Dispatcher s
 handleCallFromIf cond handler
@@ -327,11 +327,11 @@ handleCallFromIf cond handler
     , dispatchIf = checkCall cond
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (s -> CallRef b -> a -> Process (ProcessReply b s))
+                 => (CallRef b -> s -> a -> Process (ProcessReply b s))
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
-        doHandle h s (CallMessage p c) = (h s c p) >>= mkReply c
+        doHandle h s (CallMessage p c) = (h c s p) >>= mkReply c
         doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]
 
 -- | Creates a handler for a /typed channel/ RPC style interaction. The
@@ -340,7 +340,7 @@ handleCallFromIf cond handler
 -- reply to the @SendPort@.
 --
 handleRpcChan :: forall s a b . (Serializable a, Serializable b)
-              => (s -> SendPort b -> a -> Process (ProcessAction s))
+              => (SendPort b -> s -> a -> Process (ProcessAction s))
               -> Dispatcher s
 handleRpcChan = handleRpcChanIf $ input (const True)
 
@@ -349,7 +349,7 @@ handleRpcChan = handleRpcChanIf $ input (const True)
 --
 handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)
                 => Condition s a
-                -> (s -> SendPort b -> a -> Process (ProcessAction s))
+                -> (SendPort b -> s -> a -> Process (ProcessAction s))
                 -> Dispatcher s
 handleRpcChanIf c h
   = DispatchIf {
@@ -357,11 +357,11 @@ handleRpcChanIf c h
     , dispatchIf = checkRpc c
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (s -> SendPort b -> a -> Process (ProcessAction s))
+                 => (SendPort b -> s -> a -> Process (ProcessAction s))
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
-        doHandle h' s (ChanMessage p c') = h' s c' p
+        doHandle h' s (ChanMessage p c') = h' c' s p
         doHandle _  _ _ = die "RPC_HANDLER_TYPE_MISMATCH" -- node [Message type]
 
 -- | A variant of 'handleRpcChan' that ignores the state argument.
@@ -369,7 +369,7 @@ handleRpcChanIf c h
 handleRpcChan_ :: forall a b . (Serializable a, Serializable b)
                   => (SendPort b -> a -> Process (ProcessAction ()))
                   -> Dispatcher ()
-handleRpcChan_ h = handleRpcChan (\() -> h)
+handleRpcChan_ h = handleRpcChan (\sp () -> h sp)
 
 -- | A variant of 'handleRpcChanIf' that ignores the state argument.
 --
@@ -377,7 +377,7 @@ handleRpcChanIf_ :: forall a b . (Serializable a, Serializable b)
                  => Condition () a
                  -> (SendPort b -> a -> Process (ProcessAction ()))
                  -> Dispatcher ()
-handleRpcChanIf_ c h = handleRpcChanIf c (\() -> h)
+handleRpcChanIf_ c h = handleRpcChanIf c (\sp () -> h sp)
 
 -- | Constructs a 'cast' handler from an ordinary function in the 'Process'
 -- monad.
@@ -424,28 +424,28 @@ handleControlChan chan h
 --
 handleControlChan_ :: forall s a. (Serializable a)
            => ControlChannel a
-           -> (a -> (s -> Process (ProcessAction s)))
+           -> (a -> Process (ProcessAction s))
            -> Dispatcher s
 handleControlChan_ chan h
   = DispatchCC { channel    = snd $ unControl chan
-               , dispatch   = (\s ((CastMessage p) :: Message a ()) -> h p $ s)
+               , dispatch   = (\_ ((CastMessage p) :: Message a ()) -> h p)
                }
 
 -- | Version of 'handleCast' that ignores the server state.
 --
 handleCast_ :: (Serializable a)
-            => (a -> (s -> Process (ProcessAction s))) -> Dispatcher s
+            => (a -> Process (ProcessAction s)) -> Dispatcher s
 handleCast_ = handleCastIf_ $ input (const True)
 
 -- | Version of 'handleCastIf' that ignores the server state.
 --
 handleCastIf_ :: forall s a . (Serializable a)
     => Condition s a -- ^ predicate that must be satisfied for the handler to run
-    -> (a -> (s -> Process (ProcessAction s)))
+    -> (a -> Process (ProcessAction s))
         -- ^ a function from the input message to a /stateless action/, cf 'continue_'
     -> Dispatcher s
 handleCastIf_ cond h
-  = DispatchIf { dispatch   = (\s ((CastMessage p) :: Message a ()) -> h p $ s)
+  = DispatchIf { dispatch   = (\_ ((CastMessage p) :: Message a ()) -> h p)
                , dispatchIf = checkCast cond
                }
 

From 72db1d2de72715e97a9457cdb922ca3f96275a75 Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <aenor.realm@gmail.com>
Date: Tue, 8 Mar 2016 19:41:56 +0300
Subject: [PATCH 02/50] Pull together similar handler types.

---
 .../Process/ManagedProcess/Server.hs          | 34 +++++++++----------
 1 file changed, 17 insertions(+), 17 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index f007636..76a2a25 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -248,7 +248,7 @@ handleCallIf_ cond handler
 -- > handleCall = handleCallIf (const True)
 --
 handleCall :: (Serializable a, Serializable b)
-           => (s -> a -> Process (ProcessReply b s))
+           => CallHandler s a b
            -> Dispatcher s
 handleCall = handleCallIf $ state (const True)
 
@@ -260,7 +260,7 @@ handleCall = handleCallIf $ state (const True)
 --
 handleCallIf :: forall s a b . (Serializable a, Serializable b)
     => Condition s a -- ^ predicate that must be satisfied for the handler to run
-    -> (s -> a -> Process (ProcessReply b s))
+    -> CallHandler s a b
         -- ^ a reply yielding function over the process state and input message
     -> Dispatcher s
 handleCallIf cond handler
@@ -269,7 +269,7 @@ handleCallIf cond handler
     , dispatchIf = checkCall cond
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (s -> a -> Process (ProcessReply b s))
+                 => CallHandler s a b
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
@@ -309,7 +309,7 @@ handleCallFromIf_ c h =
 -- worker (or stash it away itself) and return 'noReply'.
 --
 handleCallFrom :: forall s a b . (Serializable a, Serializable b)
-           => (CallRef b -> s -> a -> Process (ProcessReply b s))
+           => (CallRef b -> CallHandler s a b)
            -> Dispatcher s
 handleCallFrom = handleCallFromIf $ state (const True)
 
@@ -318,7 +318,7 @@ handleCallFrom = handleCallFromIf $ state (const True)
 --
 handleCallFromIf :: forall s a b . (Serializable a, Serializable b)
     => Condition s a -- ^ predicate that must be satisfied for the handler to run
-    -> (CallRef b -> s -> a -> Process (ProcessReply b s))
+    -> (CallRef b -> CallHandler s a b)
         -- ^ a reply yielding function over the process state, sender and input message
     -> Dispatcher s
 handleCallFromIf cond handler
@@ -327,7 +327,7 @@ handleCallFromIf cond handler
     , dispatchIf = checkCall cond
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (CallRef b -> s -> a -> Process (ProcessReply b s))
+                 => (CallRef b -> CallHandler s a b)
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
@@ -340,7 +340,7 @@ handleCallFromIf cond handler
 -- reply to the @SendPort@.
 --
 handleRpcChan :: forall s a b . (Serializable a, Serializable b)
-              => (SendPort b -> s -> a -> Process (ProcessAction s))
+              => (SendPort b -> CastHandler s a)
               -> Dispatcher s
 handleRpcChan = handleRpcChanIf $ input (const True)
 
@@ -349,7 +349,7 @@ handleRpcChan = handleRpcChanIf $ input (const True)
 --
 handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)
                 => Condition s a
-                -> (SendPort b -> s -> a -> Process (ProcessAction s))
+                -> (SendPort b -> CastHandler s a)
                 -> Dispatcher s
 handleRpcChanIf c h
   = DispatchIf {
@@ -357,7 +357,7 @@ handleRpcChanIf c h
     , dispatchIf = checkRpc c
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (SendPort b -> s -> a -> Process (ProcessAction s))
+                 => (SendPort b -> CastHandler s a)
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
@@ -384,7 +384,7 @@ handleRpcChanIf_ c h = handleRpcChanIf c (\sp () -> h sp)
 -- > handleCast = handleCastIf (const True)
 --
 handleCast :: (Serializable a)
-           => (s -> a -> Process (ProcessAction s))
+           => CastHandler s a
            -> Dispatcher s
 handleCast = handleCastIf $ input (const True)
 
@@ -395,7 +395,7 @@ handleCast = handleCastIf $ input (const True)
 --
 handleCastIf :: forall s a . (Serializable a)
     => Condition s a -- ^ predicate that must be satisfied for the handler to run
-    -> (s -> a -> Process (ProcessAction s))
+    -> CastHandler s a
        -- ^ an action yielding function over the process state and input message
     -> Dispatcher s
 handleCastIf cond h
@@ -412,7 +412,7 @@ handleCastIf cond h
 --
 handleControlChan :: forall s a . (Serializable a)
     => ControlChannel a -- ^ the receiving end of the control channel
-    -> (s -> a -> Process (ProcessAction s))
+    -> CastHandler s a
        -- ^ an action yielding function over the process state and input message
     -> Dispatcher s
 handleControlChan chan h
@@ -463,14 +463,14 @@ action :: forall s a . (Serializable a)
           -- ^ a function from the input message to a /stateless action/, cf 'continue_'
     -> Dispatcher s
 action h = handleDispatch perform
-  where perform :: (s -> a -> Process (ProcessAction s))
+  where perform :: CastHandler s a
         perform s a = let f = h a in f s
 
 -- | Constructs a handler for both /call/ and /cast/ messages.
 -- @handleDispatch = handleDispatchIf (const True)@
 --
 handleDispatch :: forall s a . (Serializable a)
-               => (s -> a -> Process (ProcessAction s))
+               => CastHandler s a
                -> Dispatcher s
 handleDispatch = handleDispatchIf $ input (const True)
 
@@ -481,14 +481,14 @@ handleDispatch = handleDispatchIf $ input (const True)
 --
 handleDispatchIf :: forall s a . (Serializable a)
                  => Condition s a
-                 -> (s -> a -> Process (ProcessAction s))
+                 -> CastHandler s a
                  -> Dispatcher s
 handleDispatchIf cond handler = DispatchIf {
       dispatch = doHandle handler
     , dispatchIf = check cond
     }
   where doHandle :: (Serializable a)
-                 => (s -> a -> Process (ProcessAction s))
+                 => CastHandler s a
                  -> s
                  -> Message a ()
                  -> Process (ProcessAction s)
@@ -502,7 +502,7 @@ handleDispatchIf cond handler = DispatchIf {
 -- sent using the 'cast' or 'call' APIs) from an ordinary function in the
 -- 'Process' monad.
 handleInfo :: forall s a. (Serializable a)
-           => (s -> a -> Process (ProcessAction s))
+           => CastHandler s a
            -> DeferredDispatcher s
 handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h }
   where

From c6ee2b38968e8d6c1f476b278f2093cfbd780417 Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <aenor.realm@gmail.com>
Date: Wed, 9 Mar 2016 00:25:24 +0300
Subject: [PATCH 03/50] Extract CallHandler and ActionHandler and express
 others from there.

---
 .../Process/ManagedProcess/Internal/Types.hs  | 24 ++++++++-----
 .../Process/ManagedProcess/Server.hs          | 34 +++++++++----------
 .../ManagedProcess/Server/Restricted.hs       | 10 ++----
 3 files changed, 36 insertions(+), 32 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 454f5ec..d468c22 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -14,6 +14,8 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , Condition(..)
   , ProcessAction(..)
   , ProcessReply(..)
+  , ActionHandler
+  , ReplyHandler
   , CallHandler
   , CastHandler
   , DeferredCallHandler
@@ -155,27 +157,33 @@ data Condition s m =
   | State     (s -> Bool)       -- ^ predicated on the process state only
   | Input     (m -> Bool)       -- ^ predicated on the input message only
 
+-- | An expression used to handle a message.
+type ActionHandler s a = s -> a -> Process (ProcessAction s)
+
+-- | An expression used to handle a message and providing a reply.
+type ReplyHandler s a b = s -> a -> Process (ProcessReply b s)
+
 -- | An expression used to handle a /call/ message.
-type CallHandler s a b = s -> a -> Process (ProcessReply b s)
+type CallHandler s a b = ReplyHandler s a b
 
 -- | An expression used to handle a /call/ message where the reply is deferred
 -- via the 'CallRef'.
-type DeferredCallHandler s a b = s -> CallRef b -> a -> Process (ProcessReply b s)
+type DeferredCallHandler s a b = CallRef b -> CallHandler s a b
 
 -- | An expression used to handle a /call/ message in a stateless process.
-type StatelessCallHandler a b = a -> CallRef b -> Process (ProcessReply b ())
+type StatelessCallHandler a b = DeferredCallHandler () a b
 
 -- | An expression used to handle a /cast/ message.
-type CastHandler s a = s -> a -> Process (ProcessAction s)
+type CastHandler s a = ActionHandler s a
 
 -- | An expression used to handle an /info/ message.
-type InfoHandler s a = s -> a -> Process (ProcessAction s)
+type InfoHandler s a = ActionHandler s a
 
 -- | An expression used to handle a /channel/ message.
-type ChannelHandler s a b = s -> SendPort b -> a -> Process (ProcessAction s)
+type ChannelHandler s a b = SendPort b -> ActionHandler s a
 
 -- | An expression used to handle a /channel/ message in a stateless process.
-type StatelessChannelHandler a b = SendPort b -> a -> Process (ProcessAction ())
+type StatelessChannelHandler a b = ChannelHandler () a b
 
 -- | An expression used to initialise a process with its state.
 type InitHandler a s = a -> Process (InitResult s)
@@ -184,7 +192,7 @@ type InitHandler a s = a -> Process (InitResult s)
 type ShutdownHandler s = s -> ExitReason -> Process ()
 
 -- | An expression used to handle process timeouts.
-type TimeoutHandler s = s -> Delay -> Process (ProcessAction s)
+type TimeoutHandler s = ActionHandler s Delay
 
 -- dispatching to implementation callbacks
 
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 76a2a25..940a08f 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -340,7 +340,7 @@ handleCallFromIf cond handler
 -- reply to the @SendPort@.
 --
 handleRpcChan :: forall s a b . (Serializable a, Serializable b)
-              => (SendPort b -> CastHandler s a)
+              => (SendPort b -> ActionHandler s a)
               -> Dispatcher s
 handleRpcChan = handleRpcChanIf $ input (const True)
 
@@ -349,7 +349,7 @@ handleRpcChan = handleRpcChanIf $ input (const True)
 --
 handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)
                 => Condition s a
-                -> (SendPort b -> CastHandler s a)
+                -> (SendPort b -> ActionHandler s a)
                 -> Dispatcher s
 handleRpcChanIf c h
   = DispatchIf {
@@ -357,7 +357,7 @@ handleRpcChanIf c h
     , dispatchIf = checkRpc c
     }
   where doHandle :: (Serializable a, Serializable b)
-                 => (SendPort b -> CastHandler s a)
+                 => (SendPort b -> ActionHandler s a)
                  -> s
                  -> Message a b
                  -> Process (ProcessAction s)
@@ -412,7 +412,7 @@ handleCastIf cond h
 --
 handleControlChan :: forall s a . (Serializable a)
     => ControlChannel a -- ^ the receiving end of the control channel
-    -> CastHandler s a
+    -> ActionHandler s a
        -- ^ an action yielding function over the process state and input message
     -> Dispatcher s
 handleControlChan chan h
@@ -463,14 +463,14 @@ action :: forall s a . (Serializable a)
           -- ^ a function from the input message to a /stateless action/, cf 'continue_'
     -> Dispatcher s
 action h = handleDispatch perform
-  where perform :: CastHandler s a
+  where perform :: ActionHandler s a
         perform s a = let f = h a in f s
 
 -- | Constructs a handler for both /call/ and /cast/ messages.
 -- @handleDispatch = handleDispatchIf (const True)@
 --
 handleDispatch :: forall s a . (Serializable a)
-               => CastHandler s a
+               => ActionHandler s a
                -> Dispatcher s
 handleDispatch = handleDispatchIf $ input (const True)
 
@@ -481,14 +481,14 @@ handleDispatch = handleDispatchIf $ input (const True)
 --
 handleDispatchIf :: forall s a . (Serializable a)
                  => Condition s a
-                 -> CastHandler s a
+                 -> ActionHandler s a
                  -> Dispatcher s
 handleDispatchIf cond handler = DispatchIf {
       dispatch = doHandle handler
     , dispatchIf = check cond
     }
   where doHandle :: (Serializable a)
-                 => CastHandler s a
+                 => ActionHandler s a
                  -> s
                  -> Message a ()
                  -> Process (ProcessAction s)
@@ -502,12 +502,12 @@ handleDispatchIf cond handler = DispatchIf {
 -- sent using the 'cast' or 'call' APIs) from an ordinary function in the
 -- 'Process' monad.
 handleInfo :: forall s a. (Serializable a)
-           => CastHandler s a
+           => ActionHandler s a
            -> DeferredDispatcher s
 handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h }
   where
     doHandleInfo :: forall s2 a2. (Serializable a2)
-                             => (s2 -> a2 -> Process (ProcessAction s2))
+                             => ActionHandler s2 a2
                              -> s2
                              -> P.Message
                              -> Process (Maybe (ProcessAction s2))
@@ -515,7 +515,7 @@ handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h }
 
 -- | Handle completely /raw/ input messages.
 --
-handleRaw :: forall s. (s -> P.Message -> Process (ProcessAction s))
+handleRaw :: forall s. ActionHandler s P.Message
           -> DeferredDispatcher s
 handleRaw h = DeferredDispatcher { dispatchInfo = doHandle h }
   where
@@ -524,30 +524,30 @@ handleRaw h = DeferredDispatcher { dispatchInfo = doHandle h }
 -- | Creates an /exit handler/ scoped to the execution of any and all the
 -- registered call, cast and info handlers for the process.
 handleExit :: forall s a. (Serializable a)
-           => (s -> ProcessId -> a -> Process (ProcessAction s))
+           => (ProcessId -> ActionHandler s a)
            -> ExitSignalDispatcher s
 handleExit h = ExitSignalDispatcher { dispatchExit = doHandleExit h }
   where
-    doHandleExit :: (s -> ProcessId -> a -> Process (ProcessAction s))
+    doHandleExit :: (ProcessId -> ActionHandler s a)
                  -> s
                  -> ProcessId
                  -> P.Message
                  -> Process (Maybe (ProcessAction s))
-    doHandleExit h' s p msg = handleMessage msg (h' s p)
+    doHandleExit h' s p msg = handleMessage msg (h' p s)
 
 handleExitIf :: forall s a . (Serializable a)
              => (s -> a -> Bool)
-             -> (s -> ProcessId -> a -> Process (ProcessAction s))
+             -> (ProcessId -> ActionHandler s a)
              -> ExitSignalDispatcher s
 handleExitIf c h = ExitSignalDispatcher { dispatchExit = doHandleExit c h }
   where
     doHandleExit :: (s -> a -> Bool)
-                 -> (s -> ProcessId -> a -> Process (ProcessAction s))
+                 -> (ProcessId -> ActionHandler s a)
                  -> s
                  -> ProcessId
                  -> P.Message
                  -> Process (Maybe (ProcessAction s))
-    doHandleExit c' h' s p msg = handleMessageIf msg (c' s) (h' s p)
+    doHandleExit c' h' s p msg = handleMessageIf msg (c' s) (h' p s)
 
 -- handling 'reply-to' in the main process loop is awkward at best,
 -- so we handle it here instead and return the 'action' to the loop
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index 78a5cc1..71021a9 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -224,7 +224,7 @@ handleInfo h = Server.handleInfo (wrapHandler h)
 handleExit :: forall s a. (Serializable a)
            => (a -> RestrictedProcess s RestrictedAction)
            -> ExitSignalDispatcher s
-handleExit h = Server.handleExit $ \s _ a -> (wrapHandler h) s a
+handleExit h = Server.handleExit $ \_ s a -> (wrapHandler h) s a
 
 handleTimeout :: forall s . (Delay -> RestrictedProcess s RestrictedAction)
                          -> TimeoutHandler s
@@ -242,9 +242,7 @@ handleTimeout h = \s d -> do
 
 wrapHandler :: forall s a . (Serializable a)
             => (a -> RestrictedProcess s RestrictedAction)
-            -> s
-            -> a
-            -> Process (ProcessAction s)
+            -> ActionHandler s a
 wrapHandler h s a = do
   (r, s') <- runRestricted s (h a)
   case r of
@@ -255,9 +253,7 @@ wrapHandler h s a = do
 
 wrapCall :: forall s a b . (Serializable a, Serializable b)
             => (a -> RestrictedProcess s (Result b))
-            -> s
-            -> a
-            -> Process (ProcessReply b s)
+            -> CallHandler s a b
 wrapCall h s a = do
   (r, s') <- runRestricted s (h a)
   case r of

From fc4f0c3555f85d9d4f4cfa67de1d2680b6f7d169 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= <facundo.dominguez@tweag.io>
Date: Mon, 13 Jun 2016 08:08:25 -0300
Subject: [PATCH 04/50] Update maintainer field.

---
 distributed-process-client-server.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index d6fa8ba..dc42efe 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -7,7 +7,7 @@ license-file:   LICENCE
 stability:      experimental
 Copyright:      Tim Watson 2012 - 2013
 Author:         Tim Watson
-Maintainer:     Facundo Domínguez <facundo.dominguez@tweag.io>
+Maintainer:     Tim Watson <watson.timothy@gmail.com>
 Stability:      experimental
 Homepage:       http://github.com/haskell-distributed/distributed-process-client-server
 Bug-Reports:    http://github.com/haskell-distributed/distributed-process-client-server/issues

From 84b4f40cc005a361106f86737d2b98cf50e41801 Mon Sep 17 00:00:00 2001
From: AgentM <agentm@themactionfaction.com>
Date: Thu, 8 Dec 2016 21:07:22 -0500
Subject: [PATCH 05/50] make adjustments for GHC 8 support -relax cabal upper
 bound constraints -use Control.Monad.Catch (catch,finally) where appropriate
 as per deprecation warning

---
 distributed-process-client-server.cabal         | 17 ++++++++++-------
 .../Process/ManagedProcess/Internal/Types.hs    | 13 +++++++------
 .../Process/ManagedProcess/Server/Restricted.hs |  2 --
 tests/MathsDemo.hs                              |  1 -
 tests/TestManagedProcess.hs                     |  3 ++-
 tests/TestPrioritisedProcess.hs                 |  3 ++-
 tests/TestUtils.hs                              |  1 -
 7 files changed, 21 insertions(+), 19 deletions(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index dc42efe..331d0f7 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -17,7 +17,7 @@ description:    Modelled after Erlang OTP's gen_server, this framework provides
                 development into a set of modules and standards designed to help you build
                 concurrent, distributed applications with relative ease.
 category:       Control
-tested-with:    GHC == 7.4.2 GHC == 7.6.2
+tested-with:    GHC == 7.4.2 GHC == 7.6.2 GHC == 8.0.1
 data-dir:       ""
 
 source-repository head
@@ -31,16 +31,17 @@ library
                    distributed-process >= 0.5.2 && < 0.7,
                    distributed-process-extras >= 0.2.0 && < 0.3,
                    distributed-process-async >= 0.2.1 && < 0.3,
-                   binary >= 0.6.3.0 && < 0.8,
-                   deepseq >= 1.3.0.1 && < 1.5,
+                   binary >= 0.6.3.0 && < 0.9,
+                   deepseq >= 1.3.0.1 && < 1.6,
                    mtl,
                    containers >= 0.4 && < 0.6,
                    hashable >= 1.2.0.5 && < 1.3,
                    unordered-containers >= 0.2.3.0 && < 0.3,
                    fingertree < 0.2,
                    stm >= 2.4 && < 2.5,
-                   time > 1.4 && < 1.6,
-                   transformers
+                   time > 1.4 && < 1.7,
+                   transformers,
+                   exceptions >= 0.5
   if impl(ghc <= 7.5)
     Build-Depends:   template-haskell == 2.7.0.0,
                      derive == 2.5.5,
@@ -85,7 +86,8 @@ test-suite ManagedProcessTests
                    test-framework-hunit,
                    transformers,
                    rematch >= 0.2.0.0,
-                   ghc-prim
+                   ghc-prim,
+                   exceptions >= 0.5
   hs-source-dirs:
                    tests
   ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
@@ -117,7 +119,8 @@ test-suite PrioritisedProcessTests
                    test-framework-hunit,
                    transformers,
                    rematch >= 0.2.0.0,
-                   ghc-prim
+                   ghc-prim,
+                   exceptions >= 0.5
   hs-source-dirs:
                    tests
   ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 454f5ec..4a73684 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -49,7 +49,8 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
-import Control.Distributed.Process hiding (Message)
+import Control.Distributed.Process hiding (Message, finally)
+import Control.Monad.Catch (finally)
 import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Serializable
 import Control.Distributed.Process.Extras
@@ -80,10 +81,11 @@ type CallId = MonitorRef
 
 newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }
   deriving (Eq, Show, Typeable, Generic)
-instance Serializable a => Binary (CallRef a) where
-instance NFData a => NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
+--instance Serializable a => Binary (CallRef a) where
+instance Binary (CallRef a) where
+instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
 
-makeRef :: forall a . (Serializable a) => Recipient -> CallId -> CallRef a
+makeRef :: Recipient -> CallId -> CallRef a
 makeRef r c = CallRef (r, c)
 
 instance Resolvable (CallRef a) where
@@ -232,8 +234,7 @@ instance Eq (ControlPort m) where
 
 -- | Obtain an opaque expression for communicating with a 'ControlChannel'.
 --
-channelControlPort :: (Serializable m)
-                   => ControlChannel m
+channelControlPort :: ControlChannel m
                    -> ControlPort m
 channelControlPort cc = ControlPort $ fst $ unControl cc
 
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index 78a5cc1..c5fec7d 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -59,7 +59,6 @@ module Control.Distributed.Process.ManagedProcess.Server.Restricted
   , say
   ) where
 
-import Control.Applicative (Applicative)
 import Control.Distributed.Process hiding (call, say)
 import qualified Control.Distributed.Process as P (say)
 import Control.Distributed.Process.Extras
@@ -73,7 +72,6 @@ import Prelude hiding (init)
 import Control.Monad.IO.Class (MonadIO)
 import qualified Control.Monad.State as ST
   ( MonadState
-  , MonadTrans
   , StateT
   , get
   , lift
diff --git a/tests/MathsDemo.hs b/tests/MathsDemo.hs
index 8d8c24c..4c24f88 100644
--- a/tests/MathsDemo.hs
+++ b/tests/MathsDemo.hs
@@ -8,7 +8,6 @@ module MathsDemo
   , Add(..)
   ) where
 
-import Control.Applicative
 import Control.Distributed.Process hiding (call)
 import Control.Distributed.Process.Extras
 import Control.Distributed.Process.Extras.Time
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index 02af651..eaf502f 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -7,7 +7,7 @@ module Main where
 
 import Control.Concurrent.MVar
 import Control.Exception (SomeException)
-import Control.Distributed.Process hiding (call)
+import Control.Distributed.Process hiding (call, catch)
 import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send, nsend)
 import Control.Distributed.Process.ManagedProcess
@@ -30,6 +30,7 @@ import ManagedProcessCommon
 
 import qualified Network.Transport as NT
 import Control.Monad (void)
+import Control.Monad.Catch (catch)
 
 -- utilities
 
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 0f37668..1a1ab69 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -10,7 +10,7 @@ module Main where
 import Control.Concurrent.MVar
 import Control.Exception (SomeException)
 import Control.DeepSeq (NFData)
-import Control.Distributed.Process hiding (call, send)
+import Control.Distributed.Process hiding (call, send, catch)
 import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras hiding (__remoteTable)
 import Control.Distributed.Process.Async
@@ -19,6 +19,7 @@ import Control.Distributed.Process.Tests.Internal.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer
 import Control.Distributed.Process.Serializable()
+import Control.Monad.Catch (catch)
 
 import Data.Binary
 import Data.Either (rights)
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index afe68f7..a1886aa 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -17,7 +17,6 @@ import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer
-import Test.HUnit (Assertion, assertFailure)
 import Test.Framework (Test, defaultMain)
 
 import Network.Transport.TCP

From fd80d47134ba11d93bbed85cbba8fa2bff609a36 Mon Sep 17 00:00:00 2001
From: Alexander Vershilov <alexander.vershilov@gmail.com>
Date: Fri, 9 Dec 2016 23:02:52 +0300
Subject: [PATCH 06/50] Drop commented out code.

---
 .../Distributed/Process/ManagedProcess/Internal/Types.hs        | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 4a73684..57d33af 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -81,7 +81,7 @@ type CallId = MonitorRef
 
 newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }
   deriving (Eq, Show, Typeable, Generic)
---instance Serializable a => Binary (CallRef a) where
+
 instance Binary (CallRef a) where
 instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
 

From 9546780335707fc529583a01fb14b6f6a8b7d735 Mon Sep 17 00:00:00 2001
From: 3noch <eacameron@gmail.com>
Date: Wed, 25 Jan 2017 16:22:26 -0500
Subject: [PATCH 07/50] Bump upper bound on time

---
 distributed-process-client-server.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 331d0f7..089e3e7 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -39,7 +39,7 @@ library
                    unordered-containers >= 0.2.3.0 && < 0.3,
                    fingertree < 0.2,
                    stm >= 2.4 && < 2.5,
-                   time > 1.4 && < 1.7,
+                   time > 1.4 && < 1.8,
                    transformers,
                    exceptions >= 0.5
   if impl(ghc <= 7.5)

From 05eff244898cfeaf4c90867d06acd4ff34639b5c Mon Sep 17 00:00:00 2001
From: 3noch <eacameron@gmail.com>
Date: Wed, 25 Jan 2017 16:39:20 -0500
Subject: [PATCH 08/50] Bump upper bounds on binary everywhere

---
 distributed-process-client-server.cabal | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 089e3e7..449546e 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -77,7 +77,7 @@ test-suite ManagedProcessTests
                    mtl,
                    fingertree < 0.2,
                    network-transport-tcp >= 0.4 && < 0.6,
-                   binary >= 0.6.3.0 && < 0.8,
+                   binary >= 0.6.3.0 && < 0.9,
                    deepseq >= 1.3.0.1 && < 1.5,
                    network >= 2.3 && < 2.7,
                    HUnit >= 1.2 && < 2,
@@ -110,7 +110,7 @@ test-suite PrioritisedProcessTests
                    mtl,
                    fingertree < 0.2,
                    network-transport-tcp >= 0.4 && < 0.6,
-                   binary >= 0.6.3.0 && < 0.8,
+                   binary >= 0.6.3.0 && < 0.9,
                    deepseq >= 1.3.0.1 && < 1.5,
                    network >= 2.3 && < 2.7,
                    HUnit >= 1.2 && < 2,

From 0bf2b440b3bba907e325e35656462d830ee462e1 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 00:08:12 +0000
Subject: [PATCH 09/50] tweak bounds and stackify

---
 distributed-process-client-server.cabal | 18 +++++++++---------
 stack-ghc-7.10.3.yaml                   | 11 +++++++++++
 stack-ghc-8.0.1.yaml                    | 12 ++++++++++++
 stack.yaml                              | 11 +++++++++++
 4 files changed, 43 insertions(+), 9 deletions(-)
 create mode 100644 stack-ghc-7.10.3.yaml
 create mode 100644 stack-ghc-8.0.1.yaml
 create mode 100644 stack.yaml

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 449546e..215c399 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -28,9 +28,9 @@ library
   build-depends:
                    base >= 4.4 && < 5,
                    data-accessor >= 0.2.2.3,
-                   distributed-process >= 0.5.2 && < 0.7,
-                   distributed-process-extras >= 0.2.0 && < 0.3,
-                   distributed-process-async >= 0.2.1 && < 0.3,
+                   distributed-process >= 0.6.6 && < 0.7,
+                   distributed-process-extras >= 0.3.0 && < 0.4,
+                   distributed-process-async >= 0.2.3 && < 0.3,
                    binary >= 0.6.3.0 && < 0.9,
                    deepseq >= 1.3.0.1 && < 1.6,
                    mtl,
@@ -68,9 +68,9 @@ test-suite ManagedProcessTests
                    base >= 4.4 && < 5,
                    ansi-terminal >= 0.5 && < 0.7,
                    containers,
-                   distributed-process >= 0.5.2 && < 0.7,
-                   distributed-process-extras >= 0.2.0 && < 0.3,
-                   distributed-process-async >= 0.2.1 && < 0.3,
+                   distributed-process >= 0.6.6 && < 0.7,
+                   distributed-process-extras >= 0.3.0 && < 0.4,
+                   distributed-process-async >= 0.2.3 && < 0.3,
                    distributed-process-client-server,
                    distributed-process-tests >= 0.4.2 && < 0.5,
                    network-transport >= 0.4 && < 0.5,
@@ -101,9 +101,9 @@ test-suite PrioritisedProcessTests
                    base >= 4.4 && < 5,
                    ansi-terminal >= 0.5 && < 0.7,
                    containers,
-                   distributed-process >= 0.5.2 && < 0.7,
-                   distributed-process-extras >= 0.2.0 && < 0.3,
-                   distributed-process-async >= 0.2.1 && < 0.3,
+                   distributed-process >= 0.6.6 && < 0.7,
+                   distributed-process-extras >= 0.3.0 && < 0.4,
+                   distributed-process-async >= 0.2.3 && < 0.3,
                    distributed-process-client-server,
                    distributed-process-tests >= 0.4.2 && < 0.5,
                    network-transport >= 0.4 && < 0.5,
diff --git a/stack-ghc-7.10.3.yaml b/stack-ghc-7.10.3.yaml
new file mode 100644
index 0000000..0629730
--- /dev/null
+++ b/stack-ghc-7.10.3.yaml
@@ -0,0 +1,11 @@
+resolver: nightly-2016-03-08
+
+packages:
+- '.'
+- location:
+    git: https://github.com/haskell-distributed/distributed-process-systest.git
+    commit: 6b8749fd38141425e6b677d5a5137b3fe09cc127
+  extra-dep: true
+
+extra-deps:
+- distributed-process-0.6.6         # missing snapshot
diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml
new file mode 100644
index 0000000..e41d6ed
--- /dev/null
+++ b/stack-ghc-8.0.1.yaml
@@ -0,0 +1,12 @@
+resolver: lts-7.18
+
+packages:
+- '.'
+
+extra-deps:
+- network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
+- distributed-process-0.6.6         # missing snapshot
+- distributed-process-extras-0.3.0  # missing snapshot
+- distributed-process-async-0.2.4   # missing snapshot
+- distributed-process-systest-0.1.0 # missing prior to Jan-2017
+- rematch-0.2.0.0
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..962dfe9
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,11 @@
+resolver: nightly-2017-02-03
+
+packages:
+- '.'
+
+extra-deps:
+- network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
+- distributed-process-0.6.6         # missing snapshot
+- distributed-process-extras-0.3.0  # missing snapshot
+- distributed-process-systest-0.1.1 # missing prior to Jan-2017
+- rematch-0.2.0.0

From a0ecaee75d1dd79dd5401fb118aee48441f79cc7 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 00:24:47 +0000
Subject: [PATCH 10/50] travis tweaks and some *shudder* orphan instances to
 get 8.0.2 to shut up for now

---
 .travis.yml                                   | 45 ++++++++++++-------
 .../Process/ManagedProcess/Internal/Types.hs  | 23 ++++++----
 stack.yaml                                    |  4 ++
 3 files changed, 49 insertions(+), 23 deletions(-)

diff --git a/.travis.yml b/.travis.yml
index 96d9ac8..dcdb198 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,22 +1,37 @@
-language: haskell
+language: c
 
-ghc:
- - 7.8
- - 7.6
- - 7.4
+sudo: false
+
+matrix:
+  include:
+  - env: ARGS="--resolver nightly" COVER="" GHCVER=latest
+    addons: {apt: {packages: [libgmp-dev]}}
+
+cache:
+  directories:
+  - $HOME/.stack
+  - $HOME/.local
 
 before_install:
-  - cabal sandbox init
-  - for i in `cat REPOS`; do git clone http://github.com/haskell-distributed/$i; done
-  - for i in `cat REPOS`; do cabal sandbox add-source $i; done
-  - sudo apt-get update -qq
-  - sudo apt-get install -qq binutils-dev
+- export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH
+- mkdir -p ~/.local/bin
+- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+- stack --version
 
 install:
-  # Don't run tests for dependencies.
-  - cabal install --only-dependencies
-  - cabal install --only-dependencies distributed-process-tests
+- stack ${ARGS} setup --no-terminal
 
 script:
-  - cabal install
-  - cabal install --enable-tests -j1 distributed-process-tests
+- case "$COVER" in
+    true)
+      stack ${ARGS} test --coverage --no-terminal;
+      ./coverage.sh;
+      ;;
+    *)
+      stack ${ARGS} test --test-arguments='--plain'
+      ;;
+  esac
+
+notifications:
+  slack:
+    secure: g0NP1tkOe3+kI6O0Q1mgT/jPaLjxQ31J26MWouicu2F1Y3p73qTvv/QsOkafRMZDn07HlzgviCP25r7Ytg32pUAFvOh4U4MT2MpO0jUVVGPi4ZiwB+W5AH+HlDtJSickeSZ0AjXZSaGv8nQNegWkeaLQgLBIzrTHU8s0Y9K+whQ=
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 57d33af..5987a4c 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -60,6 +60,7 @@ import Control.Distributed.Process.Extras
   , Resolvable(..)
   , Routable(..)
   , NFSerializable
+  , Shutdown
   )
 import Control.Distributed.Process.Extras.Internal.Types
   ( resolveOrDie
@@ -88,13 +89,6 @@ instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
 makeRef :: Recipient -> CallId -> CallRef a
 makeRef r c = CallRef (r, c)
 
-instance Resolvable (CallRef a) where
-  resolve (CallRef (r, _)) = resolve r
-
-instance Routable (CallRef a) where
-  sendTo  (CallRef (client, tag)) msg = sendTo client (CallResponse msg tag)
-  unsafeSendTo (CallRef (c, tag)) msg = unsafeSendTo c (CallResponse msg tag)
-
 data Message a b =
     CastMessage a
   | CallMessage a (CallRef b)
@@ -106,6 +100,7 @@ instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where
   rnf (CastMessage a) = rnf a `seq` ()
   rnf (CallMessage a b) = rnf a `seq` rnf b `seq` ()
   rnf (ChanMessage a b) = rnf a `seq` rnf b `seq` ()
+instance (NFSerializable a, NFSerializable b) => NFSerializable (Message a b)
 deriving instance (Eq a, Eq b) => Eq (Message a b)
 deriving instance (Show a, Show b) => Show (Message a b)
 
@@ -115,9 +110,22 @@ data CallResponse a = CallResponse a CallId
 instance Serializable a => Binary (CallResponse a)
 instance NFSerializable a => NFData (CallResponse a) where
   rnf (CallResponse a c) = rnf a `seq` rnf c `seq` ()
+instance NFSerializable a => NFSerializable (CallResponse a)
 deriving instance Eq a => Eq (CallResponse a)
 deriving instance Show a => Show (CallResponse a)
 
+instance Resolvable (CallRef a) where
+  resolve (CallRef (r, _)) = resolve r
+
+instance Routable (CallRef a) where
+  sendTo  (CallRef (client, tag)) msg = sendTo client (CallResponse msg tag)
+  unsafeSendTo (CallRef (c, tag)) msg = unsafeSendTo c (CallResponse msg tag)
+
+-- yuk yuk, move these back into -extras before we release...
+
+instance NFSerializable Shutdown
+instance NFSerializable ()
+
 -- | Return type for and 'InitHandler' expression.
 data InitResult s =
     InitOk s Delay {-
@@ -417,4 +425,3 @@ waitResponse mTimeout cRef =
     case mTimeout of
       (Just ti) -> finally (receiveTimeout (asTimeout ti) matchers) (unmonitor mRef)
       Nothing   -> finally (receiveWait matchers >>= return . Just) (unmonitor mRef)
-
diff --git a/stack.yaml b/stack.yaml
index 962dfe9..9437c2a 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,6 +2,10 @@ resolver: nightly-2017-02-03
 
 packages:
 - '.'
+- location:
+    git: https://github.com/haskell-distributed/distributed-process-async.git
+    commit: 7c353e52b183519c6273ef62639e55eb859cc5c8
+  extra-dep: true
 
 extra-deps:
 - network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18

From a2e8f9168515258ade980b2e70b0a5bc8972b399 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 02:42:10 +0000
Subject: [PATCH 11/50] reference the right test libraries

---
 distributed-process-client-server.cabal | 4 ++--
 tests/TestManagedProcess.hs             | 2 +-
 tests/TestPrioritisedProcess.hs         | 2 +-
 3 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 215c399..14a0a16 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -72,7 +72,7 @@ test-suite ManagedProcessTests
                    distributed-process-extras >= 0.3.0 && < 0.4,
                    distributed-process-async >= 0.2.3 && < 0.3,
                    distributed-process-client-server,
-                   distributed-process-tests >= 0.4.2 && < 0.5,
+                   distributed-process-systest >= 0.1.1 && < 0.2,
                    network-transport >= 0.4 && < 0.5,
                    mtl,
                    fingertree < 0.2,
@@ -105,7 +105,7 @@ test-suite PrioritisedProcessTests
                    distributed-process-extras >= 0.3.0 && < 0.4,
                    distributed-process-async >= 0.2.3 && < 0.3,
                    distributed-process-client-server,
-                   distributed-process-tests >= 0.4.2 && < 0.5,
+                   distributed-process-systest >= 0.1.1 && < 0.2,
                    network-transport >= 0.4 && < 0.5,
                    mtl,
                    fingertree < 0.2,
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index eaf502f..e1c5264 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -11,7 +11,7 @@ import Control.Distributed.Process hiding (call, catch)
 import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send, nsend)
 import Control.Distributed.Process.ManagedProcess
-import Control.Distributed.Process.Tests.Internal.Utils
+import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Serializable()
 
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 1a1ab69..193b72f 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -15,7 +15,7 @@ import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras hiding (__remoteTable)
 import Control.Distributed.Process.Async
 import Control.Distributed.Process.ManagedProcess
-import Control.Distributed.Process.Tests.Internal.Utils
+import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer
 import Control.Distributed.Process.Serializable()

From 7abda8783bc3491a5d5ed00836456eb059f16f8f Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 02:43:46 +0000
Subject: [PATCH 12/50] Put back in a missing test case

---
 tests/TestManagedProcess.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index e1c5264..e0bafcb 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -187,6 +187,10 @@ tests transport = do
             (delayedAssertion
              "expected pong back from the server"
              localNode (Just "pong") (testUnsafeBasicCast $ wrap server))
+          , testCase "basic channel based rpc"
+            (delayedAssertion
+             "expected response back from the server"
+             localNode True testChannelBasedService)
           , testCase "cast and explicit server timeout"
             (delayedAssertion
              "expected the server to stop after the timeout"
@@ -294,4 +298,3 @@ tests transport = do
 
 main :: IO ()
 main = testMain $ tests
-

From 65281a961663d2294c857d59a37f4a22cacf4f1d Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 02:44:25 +0000
Subject: [PATCH 13/50] GHC 8.x is now very fussy, work around for now by
 adding orphan instances

---
 tests/ManagedProcessCommon.hs   | 15 ++++++++++++---
 tests/TestPrioritisedProcess.hs |  3 +--
 2 files changed, 13 insertions(+), 5 deletions(-)

diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 6320911..3e098d5 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -5,7 +5,8 @@ module ManagedProcessCommon where
 import Control.Concurrent.MVar (MVar)
 import Control.Distributed.Process hiding (call, send)
 import Control.Distributed.Process.Extras hiding (monitor)
-import Control.Distributed.Process.Tests.Internal.Utils
+import qualified Control.Distributed.Process as P
+import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer
 import Control.Distributed.Process.Async
@@ -34,7 +35,7 @@ explodingTestProcess pid =
        handleExit  (\s _ (m :: String) -> send pid (m :: String) >>
                                           continue s)
      , handleExit  (\s _ m@((_ :: ProcessId),
-                            (_ :: Int)) -> send pid m >> continue s)
+                            (_ :: Int)) -> P.send pid m >> continue s)
      ]
   }
 
@@ -107,6 +108,9 @@ testControlledTimeout launch result = do
   cast pid ("timeout", Delay $ within 1 Seconds)
   waitForExit exitReason >>= stash result
 
+instance NFSerializable (String, ProcessId) where
+instance NFSerializable (String, Delay) where
+
 testUnsafeControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process ()
 testUnsafeControlledTimeout launch result = do
   (pid, exitReason) <- launch ()
@@ -183,6 +187,8 @@ testDeadLetterPolicy launch result = do
     (after 5 Seconds)
     [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result
 
+instance NFSerializable (String, Int) where
+
 testUnsafeDeadLetterPolicy :: Launcher ProcessId
                      -> TestResult (Maybe (String, Int))
                      -> Process ()
@@ -240,6 +246,8 @@ testKillMidCall launch result = do
         unpack res sid AsyncCancelled = kill sid "stop" >> stash res True
         unpack res sid _              = kill sid "stop" >> stash res False
 
+instance NFSerializable (String, TimeInterval) where
+
 testUnsafeKillMidCall :: Launcher () -> TestResult Bool -> Process ()
 testUnsafeKillMidCall launch result = do
   (pid, _) <- launch ()
@@ -294,6 +302,8 @@ testAlternativeErrorHandling launch result = do
   shutdown pid
   waitForExit exitReason >>= stash result
 
+instance NFSerializable Int where
+
 testUnsafeAlternativeErrorHandling :: Launcher ProcessId
                              -> TestResult (Maybe ExitReason)
                              -> Process ()
@@ -310,4 +320,3 @@ testUnsafeAlternativeErrorHandling launch result = do
 
   Unsafe.shutdown pid
   waitForExit exitReason >>= stash result
-
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 193b72f..a255182 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -84,6 +84,7 @@ data MyAlarmSignal = MyAlarmSignal
   deriving (Typeable, Generic, Show, Eq)
 instance Binary MyAlarmSignal where
 instance NFData MyAlarmSignal where
+instance NFSerializable MyAlarmSignal where
 
 mkPrioritisedServer :: Process ProcessId
 mkPrioritisedServer =
@@ -218,5 +219,3 @@ tests transport = do
 
 main :: IO ()
 main = testMain $ tests
-
-

From e20135fb6a2ae4dd283fa341315990ae1323b088 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 02:45:12 +0000
Subject: [PATCH 14/50] Provide a way for STM actions to be composed alongside
 api handlers

---
 .../ManagedProcess/Internal/GenProcess.hs     | 10 +++++--
 .../Process/ManagedProcess/Internal/Types.hs  | 28 +++++++++++++------
 .../Process/ManagedProcess/Server.hs          | 15 +++++++++-
 3 files changed, 41 insertions(+), 12 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index e054191..8753c63 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -40,6 +40,9 @@ import Prelude hiding (init)
 -- Priority Mailbox Handling                                                  --
 --------------------------------------------------------------------------------
 
+-- TODO: we need to actually utilise recvTimeout on the prioritised pdef, such
+-- that a busy mailbox can't prevent us from operating normally.
+
 type Queue = PriorityQ Int P.Message
 type TimeoutSpec = (Delay, Maybe (TimerRef, (STM ())))
 data TimeoutAction s = Stop s ExitReason | Go Delay s
@@ -52,8 +55,10 @@ precvLoop ppDef pState recvDelay = do
   where
     verify pDef = mapM_ disallowCC $ apiHandlers pDef
 
-    disallowCC (DispatchCC _ _) = die $ ExitOther "IllegalControlChannel"
-    disallowCC _                = return ()
+    -- TODO: better failure messages here!
+    disallowCC (DispatchCC _ _)  = die $ ExitOther "IllegalControlChannel"
+    disallowCC (DispatchSTM _ _) = die $ ExitOther "IllegalSTMAction"
+    disallowCC _                 = return ()
 
 recvQueue :: PrioritisedProcessDefinition s
           -> s
@@ -325,4 +330,3 @@ applyPolicy p s m =
   where
     logIt =
       Log.report Log.info Log.logChannel $ "Unhandled Gen Input Message: " ++ (show m)
-
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 5987a4c..4238fcb 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LiberalTypeSynonyms        #-}
 
 -- | Types used throughout the ManagedProcess framework
 module Control.Distributed.Process.ManagedProcess.Internal.Types
@@ -49,6 +50,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
+import Control.Concurrent.STM (STM)
 import Control.Distributed.Process hiding (Message, finally)
 import Control.Monad.Catch (finally)
 import qualified Control.Distributed.Process as P (Message)
@@ -265,6 +267,12 @@ data Dispatcher s =
       channel  :: ReceivePort (Message a b)
     , dispatch :: s -> Message a b -> Process (ProcessAction s)
     }
+  | forall a .
+    DispatchSTM -- arbitrary STM actions
+    {
+      stmAction   :: STM a
+    , stmDispatch :: s -> a -> Process (ProcessAction s)
+    }
 
 -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.
 data DeferredDispatcher s =
@@ -289,9 +297,10 @@ class MessageMatcher d where
   matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)
 
 instance MessageMatcher Dispatcher where
-  matchDispatch _ s (Dispatch   d)      = match (d s)
-  matchDispatch _ s (DispatchIf d cond) = matchIf (cond s) (d s)
-  matchDispatch _ s (DispatchCC c d)    = matchChan c (d s)
+  matchDispatch _ s (Dispatch    d)      = match (d s)
+  matchDispatch _ s (DispatchIf  d cond) = matchIf (cond s) (d s)
+  matchDispatch _ s (DispatchCC  c d)    = matchChan c (d s)
+  matchDispatch _ s (DispatchSTM c d)    = matchSTM  c (d s)
 
 class DynMessageHandler d where
   dynHandleMessage :: UnhandledMessagePolicy
@@ -301,9 +310,10 @@ class DynMessageHandler d where
                    -> Process (Maybe (ProcessAction s))
 
 instance DynMessageHandler Dispatcher where
-  dynHandleMessage _ s (Dispatch   d)   msg = handleMessage   msg (d s)
-  dynHandleMessage _ s (DispatchIf d c) msg = handleMessageIf msg (c s) (d s)
-  dynHandleMessage _ _ (DispatchCC _ _) _   = error "ThisCanNeverHappen"
+  dynHandleMessage _ s (Dispatch    d)   msg = handleMessage   msg (d s)
+  dynHandleMessage _ s (DispatchIf  d c) msg = handleMessageIf msg (c s) (d s)
+  dynHandleMessage _ _ (DispatchCC  _ _) _   = error "ThisCanNeverHappen"
+  dynHandleMessage _ _ (DispatchSTM _ _) _   = error "ThisCanNeverHappen"
 
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
@@ -399,8 +409,10 @@ initCall sid msg = do
     sendTo pid (CallMessage msg cRef :: Message a b)
     return cRef
 
-unsafeInitCall :: forall s a b . (Addressable s,
-                                  NFSerializable a, NFSerializable b)
+unsafeInitCall :: forall s a b . ( Addressable s
+                                 , NFSerializable a
+                                 , NFSerializable b
+                                 )
          => s -> a -> Process (CallRef b)
 unsafeInitCall sid msg = do
   pid <- resolveOrDie sid "unsafeInitCall: unresolveable address "
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index e33ae6e..2ad6313 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -64,8 +64,11 @@ module Control.Distributed.Process.ManagedProcess.Server
     -- * Working with Control Channels
   , handleControlChan
   , handleControlChan_
+    -- * Working with external/STM actions
+  , handleExternal
   ) where
 
+import Control.Concurrent.STM (STM)
 import Control.Distributed.Process hiding (call, Message)
 import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Serializable
@@ -81,6 +84,11 @@ import Prelude hiding (init)
 -- Producing ProcessAction and ProcessReply from inside handler expressions   --
 --------------------------------------------------------------------------------
 
+-- note [Message type]: Since we own both client and server portions of the
+-- codebase, we know for certain which types will be passed to which kinds
+-- of handler, so the catch-all cases that @die $ "THIS_CAN_NEVER_HAPPEN"@ and
+-- such, are relatively sane despite appearances!
+
 -- | Creates a 'Condition' from a function that takes a process state @a@ and
 -- an input message @b@ and returns a 'Bool' indicating whether the associated
 -- handler should run.
@@ -404,6 +412,12 @@ handleCastIf cond h
     , dispatchIf = checkCast cond
     }
 
+handleExternal :: forall s a .
+       STM a
+    -> (s -> a -> Process (ProcessAction s))
+    -> Dispatcher s
+handleExternal = DispatchSTM
+
 -- | Constructs a /control channel/ handler from a function in the
 -- 'Process' monad. The handler expression returns no reply, and the
 -- /control message/ is treated in the same fashion as a 'cast'.
@@ -597,4 +611,3 @@ decode :: Message a b -> a
 decode (CallMessage a _) = a
 decode (CastMessage a)   = a
 decode (ChanMessage a _) = a
-

From ac5265f7e3f35dafe2d79492136221aaa9b80d43 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 03:03:28 +0000
Subject: [PATCH 15/50] Add test cases and fix test compilation

---
 .../Distributed/Process/ManagedProcess.hs     |  3 +-
 tests/ManagedProcessCommon.hs                 |  1 +
 tests/TestManagedProcess.hs                   | 34 +++++++++++++++++++
 3 files changed, 37 insertions(+), 1 deletion(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index af18ba7..fbf8cab 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -386,6 +386,8 @@ module Control.Distributed.Process.ManagedProcess
   , channelControlPort
   , handleControlChan
   , handleControlChan_
+    -- * Arbitrary STM actions
+  , handleExternal
     -- * Prioritised mailboxes
   , module Control.Distributed.Process.ManagedProcess.Server.Priority
     -- * Constructing handler results
@@ -522,4 +524,3 @@ statelessProcess = defaultProcess :: ProcessDefinition ()
 -- state (i.e., unit) and the given 'Delay'.
 statelessInit :: Delay -> InitHandler () ()
 statelessInit d () = return $ InitOk () d
-
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 3e098d5..ddd236e 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances   #-}
 
 module ManagedProcessCommon where
 
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index e0bafcb..e419eba 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -5,6 +5,8 @@
 
 module Main where
 
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TQueue (newTQueueIO, readTQueue, writeTQueue)
 import Control.Concurrent.MVar
 import Control.Exception (SomeException)
 import Control.Distributed.Process hiding (call, catch)
@@ -94,6 +96,30 @@ testChannelBasedService result =
     stash result (echo == "hello")
     kill pid "done"
 
+testExternalService :: TestResult Bool -> Process ()
+testExternalService result = do
+  inChan <- liftIO $ newTQueueIO
+  replyChan <- liftIO $ newTQueueIO
+  let procDef = statelessProcess {
+                    apiHandlers = [
+                      handleExternal
+                        (readTQueue inChan)
+                        (\s (m :: String) -> do
+                            liftIO $ atomically $ writeTQueue replyChan m
+                            continue s)
+                    ]
+                    }
+  let txt = "hello 2-way stm foo"
+  pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
+  echoTxt <- liftIO $ do
+    -- firstly we write something that the server can receive
+    atomically $ writeTQueue inChan txt
+    -- then sit and wait for it to write something back to us
+    atomically $ readTQueue replyChan
+
+  stash result (echoTxt == txt)
+  kill pid "done"
+
 -- MathDemo tests
 
 testAdd :: ProcessId -> TestResult Double -> Process ()
@@ -191,6 +217,14 @@ tests transport = do
             (delayedAssertion
              "expected response back from the server"
              localNode True testChannelBasedService)
+          , testCase "invalid return type handling"
+            (delayedAssertion
+             "expected response to fail on runtime type verification"
+             localNode True testCallReturnTypeMismatchHandling)
+          , testCase "taking arbitrary STM actions"
+            (delayedAssertion
+             "expected the server to read the STM queue and reply using STM"
+             localNode True testExternalService)
           , testCase "cast and explicit server timeout"
             (delayedAssertion
              "expected the server to stop after the timeout"

From 15319ae2a0d4f7ce8724ccd89de3b7a47cb3c730 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 18:10:19 +0000
Subject: [PATCH 16/50] Map `call` semantics onto STM actions and provide an
 API

---
 .../Distributed/Process/ManagedProcess.hs     |   5 +-
 .../Process/ManagedProcess/Client.hs          |  11 ++
 .../Process/ManagedProcess/Internal/Types.hs  |  26 ++-
 .../Process/ManagedProcess/Server.hs          |  25 ++-
 .../Process/ManagedProcess/UnsafeClient.hs    |   2 +-
 tests/TestManagedProcess.hs                   | 179 ++++++++++++------
 6 files changed, 174 insertions(+), 74 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index fbf8cab..537c607 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -1,8 +1,5 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE RecordWildCards            #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -388,6 +385,8 @@ module Control.Distributed.Process.ManagedProcess
   , handleControlChan_
     -- * Arbitrary STM actions
   , handleExternal
+  , handleExternal_
+  , handleCallExternal
     -- * Prioritised mailboxes
   , module Control.Distributed.Process.ManagedProcess.Server.Priority
     -- * Constructing handler results
diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 0fc6904..747c4d1 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -28,8 +28,10 @@ module Control.Distributed.Process.ManagedProcess.Client
   , callChan
   , syncCallChan
   , syncSafeCallChan
+  , callSTM
   ) where
 
+import Control.Concurrent.STM (atomically, STM)
 import Control.Distributed.Process hiding (call)
 import Control.Distributed.Process.Serializable
 import Control.Distributed.Process.Async hiding (check)
@@ -162,3 +164,12 @@ syncSafeCallChan server msg = do
   rp <- callChan server msg
   awaitResponse server [ matchChan rp (return . Right) ]
 
+callSTM :: forall s a b . (Addressable s)
+         => s
+         -> (a -> STM ())
+         -> STM b
+         -> a
+         -> Process (Either ExitReason b)
+callSTM server writeAction readAction input = do
+  liftIO $ atomically $ writeAction input
+  awaitResponse server [ matchSTM readAction (return . Right) ]
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 4238fcb..a345a4c 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -50,7 +50,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
-import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM (STM, atomically)
 import Control.Distributed.Process hiding (Message, finally)
 import Control.Monad.Catch (finally)
 import qualified Control.Distributed.Process as P (Message)
@@ -273,6 +273,12 @@ data Dispatcher s =
       stmAction   :: STM a
     , stmDispatch :: s -> a -> Process (ProcessAction s)
     }
+  | forall a .
+    DispatchExtern
+    {
+      stmAction   :: STM a
+    , stmDispatch :: s -> a -> Process (ProcessAction s)
+    }
 
 -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.
 data DeferredDispatcher s =
@@ -297,10 +303,11 @@ class MessageMatcher d where
   matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)
 
 instance MessageMatcher Dispatcher where
-  matchDispatch _ s (Dispatch    d)      = match (d s)
-  matchDispatch _ s (DispatchIf  d cond) = matchIf (cond s) (d s)
-  matchDispatch _ s (DispatchCC  c d)    = matchChan c (d s)
-  matchDispatch _ s (DispatchSTM c d)    = matchSTM  c (d s)
+  matchDispatch _ s (Dispatch    d)        = match (d s)
+  matchDispatch _ s (DispatchIf  d cond)   = matchIf (cond s) (d s)
+  matchDispatch _ s (DispatchCC  c d)      = matchChan c (d s)
+  matchDispatch _ s (DispatchSTM c d)      = matchSTM c (d s)
+  matchDispatch _ s (DispatchExtern r d)   = matchSTM r (d s)
 
 class DynMessageHandler d where
   dynHandleMessage :: UnhandledMessagePolicy
@@ -310,10 +317,11 @@ class DynMessageHandler d where
                    -> Process (Maybe (ProcessAction s))
 
 instance DynMessageHandler Dispatcher where
-  dynHandleMessage _ s (Dispatch    d)   msg = handleMessage   msg (d s)
-  dynHandleMessage _ s (DispatchIf  d c) msg = handleMessageIf msg (c s) (d s)
-  dynHandleMessage _ _ (DispatchCC  _ _) _   = error "ThisCanNeverHappen"
-  dynHandleMessage _ _ (DispatchSTM _ _) _   = error "ThisCanNeverHappen"
+  dynHandleMessage _ s (Dispatch       d)   msg = handleMessage   msg (d s)
+  dynHandleMessage _ s (DispatchIf     d c) msg = handleMessageIf msg (c s) (d s)
+  dynHandleMessage _ _ (DispatchCC     _ _) _   = error "ThisCanNeverHappen"
+  dynHandleMessage _ _ (DispatchSTM    _ _) _   = error "ThisCanNeverHappen"
+  dynHandleMessage _ _ (DispatchExtern _ _) _   = error "ThisCanNeverHappen"
 
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 2ad6313..232620a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -66,9 +66,11 @@ module Control.Distributed.Process.ManagedProcess.Server
   , handleControlChan_
     -- * Working with external/STM actions
   , handleExternal
+  , handleExternal_
+  , handleCallExternal
   ) where
 
-import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM (STM, atomically)
 import Control.Distributed.Process hiding (call, Message)
 import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Serializable
@@ -418,6 +420,27 @@ handleExternal :: forall s a .
     -> Dispatcher s
 handleExternal = DispatchSTM
 
+handleExternal_ :: forall s a .
+       STM a
+    -> (a -> (s -> Process (ProcessAction s)))
+    -> Dispatcher s
+handleExternal_ a h = DispatchSTM a (\s m -> (h m) s)
+
+handleCallExternal :: forall s r w .
+                      STM r
+                   -> (w -> STM ())
+                   -> CallHandler s r w
+                   -> Dispatcher s
+handleCallExternal reader writer handler
+  = DispatchExtern { stmAction   = reader
+                   , stmDispatch = doStmReply handler
+                   }
+  where
+    doStmReply d s m = d s m >>= doXfmReply writer
+
+    doXfmReply _ (NoReply a)         = return a
+    doXfmReply w (ProcessReply r' a) = liftIO (atomically $ w r') >> return a
+
 -- | Constructs a /control channel/ handler from a function in the
 -- 'Process' monad. The handler expression returns no reply, and the
 -- /control message/ is treated in the same fashion as a 'cast'.
diff --git a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
index c3b801e..b25e9a3 100644
--- a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE LiberalTypeSynonyms        #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -178,4 +179,3 @@ syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializa
 syncSafeCallChan server msg = do
   rp <- callChan server msg
   awaitResponse server [ matchChan rp (return . Right) ]
-
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index e419eba..02018c2 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -2,11 +2,17 @@
 {-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE RecordWildCards     #-}
 
 module Main where
 
 import Control.Concurrent.STM (atomically)
-import Control.Concurrent.STM.TQueue (newTQueueIO, readTQueue, writeTQueue)
+import Control.Concurrent.STM.TQueue
+ ( newTQueueIO
+ , readTQueue
+ , writeTQueue
+ , TQueue
+ )
 import Control.Concurrent.MVar
 import Control.Exception (SomeException)
 import Control.Distributed.Process hiding (call, catch)
@@ -120,6 +126,49 @@ testExternalService result = do
   stash result (echoTxt == txt)
   kill pid "done"
 
+data StmServer = StmServer { serverPid  :: ProcessId
+                           , writerChan :: TQueue String
+                           , readerChan :: TQueue String
+                           }
+
+instance Resolvable StmServer where
+  resolve = return . Just . serverPid
+
+instance Killable StmServer where
+  killProc StmServer{..} = kill serverPid
+  exitProc StmServer{..} = exit serverPid
+
+echoStm :: StmServer -> String -> Process (Either ExitReason String)
+echoStm StmServer{..} = callSTM serverPid
+                                (writeTQueue writerChan)
+                                (readTQueue  readerChan)
+
+launchEchoServer :: Process StmServer
+launchEchoServer = do
+  (inQ, replyQ) <- liftIO $ do
+    cIn <- newTQueueIO
+    cOut <- newTQueueIO
+    return (cIn, cOut)
+
+  let procDef = statelessProcess {
+                  apiHandlers = [
+                    handleCallExternal
+                      (readTQueue inQ)
+                      (writeTQueue replyQ)
+                      (\st (msg :: String) -> reply msg st)
+                  ]
+                }
+
+  pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
+  return $ StmServer pid inQ replyQ
+
+testExternalCall :: TestResult Bool -> Process ()
+testExternalCall result = do
+  let txt = "hello stm-call foo"
+  srv <- launchEchoServer
+  echoStm srv txt >>= stash result . (== Right txt)
+  killProc srv "done"
+
 -- MathDemo tests
 
 testAdd :: ProcessId -> TestResult Double -> Process ()
@@ -188,7 +237,7 @@ tests transport = do
   _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid
   safeCounter <- takeMVar scpid
   return [
-        testGroup "basic server functionality" [
+        testGroup "Basic Client/Server Functionality" [
             testCase "basic call with explicit server reply"
             (delayedAssertion
              "expected a response from the server"
@@ -217,14 +266,78 @@ tests transport = do
             (delayedAssertion
              "expected response back from the server"
              localNode True testChannelBasedService)
+             ]
+           , testGroup "Unhandled Message Policies" [
+              testCase "unhandled input when policy = Terminate"
+              (delayedAssertion
+               "expected the server to stop upon receiving unhandled input"
+               localNode (Just $ ExitOther "UnhandledInput")
+               (testTerminatePolicy $ wrap server))
+            , testCase "(unsafe) unhandled input when policy = Terminate"
+              (delayedAssertion
+               "expected the server to stop upon receiving unhandled input"
+               localNode (Just $ ExitOther "UnhandledInput")
+               (testUnsafeTerminatePolicy $ wrap server))
+            , testCase "unhandled input when policy = Drop"
+              (delayedAssertion
+               "expected the server to ignore unhandled input and exit normally"
+               localNode Nothing (testDropPolicy $ wrap (mkServer Drop)))
+            , testCase "(unsafe) unhandled input when policy = Drop"
+              (delayedAssertion
+               "expected the server to ignore unhandled input and exit normally"
+               localNode Nothing (testUnsafeDropPolicy $ wrap (mkServer Drop)))
+            , testCase "unhandled input when policy = DeadLetter"
+              (delayedAssertion
+               "expected the server to forward unhandled messages"
+               localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))
+               (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))
+            , testCase "(unsafe) unhandled input when policy = DeadLetter"
+              (delayedAssertion
+               "expected the server to forward unhandled messages"
+               localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))
+               (testUnsafeDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))
+            , testCase "incoming messages are ignored whilst hibernating"
+              (delayedAssertion
+               "expected the server to remain in hibernation"
+               localNode True (testHibernation $ wrap server))
+            , testCase "(unsafe) incoming messages are ignored whilst hibernating"
+              (delayedAssertion
+               "expected the server to remain in hibernation"
+               localNode True (testUnsafeHibernation $ wrap server))
+          ]
+        , testGroup "Server Exit Handling" [
+              testCase "simple exit handling"
+              (delayedAssertion "expected handler to catch exception and continue"
+               localNode Nothing (testSimpleErrorHandling $ explodingServer))
+            , testCase "(unsafe) simple exit handling"
+              (delayedAssertion "expected handler to catch exception and continue"
+               localNode Nothing (testUnsafeSimpleErrorHandling $ explodingServer))
+            , testCase "alternative exit handlers"
+              (delayedAssertion "expected handler to catch exception and continue"
+               localNode Nothing (testAlternativeErrorHandling $ explodingServer))
+            , testCase "(unsafe) alternative exit handlers"
+              (delayedAssertion "expected handler to catch exception and continue"
+               localNode Nothing (testUnsafeAlternativeErrorHandling $ explodingServer))
+          ]
+        , testGroup "Advanced Server Interactions" [
+            testCase "taking arbitrary STM actions"
+            (delayedAssertion
+             "expected the server to read the STM queue and reply using STM"
+             localNode True testExternalService)
+          , testCase "using callSTM to manage non-CH interactions"
+            (delayedAssertion
+             "expected the server to reply back via the TQueue"
+             localNode True testExternalCall)
+          , testCase "long running call cancellation"
+            (delayedAssertion "expected to get AsyncCancelled"
+             localNode True (testKillMidCall $ wrap server))
+          , testCase "(unsafe) long running call cancellation"
+            (delayedAssertion "expected to get AsyncCancelled"
+            localNode True (testUnsafeKillMidCall $ wrap server))
           , testCase "invalid return type handling"
             (delayedAssertion
              "expected response to fail on runtime type verification"
              localNode True testCallReturnTypeMismatchHandling)
-          , testCase "taking arbitrary STM actions"
-            (delayedAssertion
-             "expected the server to read the STM queue and reply using STM"
-             localNode True testExternalService)
           , testCase "cast and explicit server timeout"
             (delayedAssertion
              "expected the server to stop after the timeout"
@@ -233,60 +346,6 @@ tests transport = do
             (delayedAssertion
              "expected the server to stop after the timeout"
              localNode (Just $ ExitOther "timeout") (testUnsafeControlledTimeout $ wrap server))
-          , testCase "unhandled input when policy = Terminate"
-            (delayedAssertion
-             "expected the server to stop upon receiving unhandled input"
-             localNode (Just $ ExitOther "UnhandledInput")
-             (testTerminatePolicy $ wrap server))
-          , testCase "(unsafe) unhandled input when policy = Terminate"
-            (delayedAssertion
-             "expected the server to stop upon receiving unhandled input"
-             localNode (Just $ ExitOther "UnhandledInput")
-             (testUnsafeTerminatePolicy $ wrap server))
-          , testCase "unhandled input when policy = Drop"
-            (delayedAssertion
-             "expected the server to ignore unhandled input and exit normally"
-             localNode Nothing (testDropPolicy $ wrap (mkServer Drop)))
-          , testCase "(unsafe) unhandled input when policy = Drop"
-            (delayedAssertion
-             "expected the server to ignore unhandled input and exit normally"
-             localNode Nothing (testUnsafeDropPolicy $ wrap (mkServer Drop)))
-          , testCase "unhandled input when policy = DeadLetter"
-            (delayedAssertion
-             "expected the server to forward unhandled messages"
-             localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))
-             (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))
-          , testCase "(unsafe) unhandled input when policy = DeadLetter"
-            (delayedAssertion
-             "expected the server to forward unhandled messages"
-             localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))
-             (testUnsafeDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))
-          , testCase "incoming messages are ignored whilst hibernating"
-            (delayedAssertion
-             "expected the server to remain in hibernation"
-             localNode True (testHibernation $ wrap server))
-          , testCase "(unsafe) incoming messages are ignored whilst hibernating"
-            (delayedAssertion
-             "expected the server to remain in hibernation"
-             localNode True (testUnsafeHibernation $ wrap server))
-          , testCase "long running call cancellation"
-            (delayedAssertion "expected to get AsyncCancelled"
-             localNode True (testKillMidCall $ wrap server))
-          , testCase "(unsafe) long running call cancellation"
-            (delayedAssertion "expected to get AsyncCancelled"
-             localNode True (testUnsafeKillMidCall $ wrap server))
-          , testCase "simple exit handling"
-            (delayedAssertion "expected handler to catch exception and continue"
-             localNode Nothing (testSimpleErrorHandling $ explodingServer))
-          , testCase "(unsafe) simple exit handling"
-            (delayedAssertion "expected handler to catch exception and continue"
-             localNode Nothing (testUnsafeSimpleErrorHandling $ explodingServer))
-          , testCase "alternative exit handlers"
-            (delayedAssertion "expected handler to catch exception and continue"
-             localNode Nothing (testAlternativeErrorHandling $ explodingServer))
-          , testCase "(unsafe) alternative exit handlers"
-            (delayedAssertion "expected handler to catch exception and continue"
-             localNode Nothing (testUnsafeAlternativeErrorHandling $ explodingServer))
           ]
         , testGroup "math server examples" [
             testCase "error (Left) returned from x / 0"

From 04d6349aa1664a8f1b64588f6dd1dee6f406071b Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:46:36 +0000
Subject: [PATCH 17/50] fix(doc): prioritised process definitions cannot
 utilise control channels or STM actions

---
 src/Control/Distributed/Process/ManagedProcess.hs | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 537c607..759cf1d 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -226,6 +226,13 @@
 -- Using a prioritised process is as simple as calling 'pserve' instead of
 -- 'serve', and passing an initialised 'PrioritisedProcessDefinition'.
 --
+-- Note that prioritised process definitions cannot utilise control channels,
+-- not can the @handleExternal@ family of expressions be used with them. This
+-- constraint is currenly not enforced by the compiler, and calling @pserve@
+-- with a @ProcessDefinition@ containing any of these items will fail with
+-- either @ExitOther "IllegalControlChannel"@ or @ExitOther "IllegalSTMAction"@
+-- at runtime.
+--
 -- [Control Channels]
 --
 -- For advanced users and those requiring very low latency, a prioritised

From 58e298a9c8ddcec68f5192d8772e92883b36cdbb Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:47:17 +0000
Subject: [PATCH 18/50] document handleExternal

---
 .../Distributed/Process/ManagedProcess/Server.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 232620a..22141c1 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -414,6 +414,22 @@ handleCastIf cond h
     , dispatchIf = checkCast cond
     }
 
+-- | Creates a generic input handler for @STM@ actions, from an ordinary
+-- function in the 'Process' monad. The @STM a@ action tells the server how
+-- to read inputs, which when presented are passed to the handler in the same
+-- manner as @handleInfo@ messages would be.
+--
+-- Note that messages sent to the server's mailbox will never match this
+-- handler, only data arriving via the @STM a@ action will.
+--
+-- Notably, this kind of handler can be used to pass non-serialisable data to
+-- a server process. In such situations, the programmer is responsible for
+-- managing the underlying @STM@ infrastructure, and the server simply composes
+-- the @STM a@ action with the other reads on its mailbox, using the underlying
+-- @matchSTM@ API from distributed-process.
+--
+-- NB: this function cannot be used with a prioristised process definition.
+--
 handleExternal :: forall s a .
        STM a
     -> (s -> a -> Process (ProcessAction s))

From 139ec87bfcb84dfd1a8d08f0274a6e5efadfaf8e Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:47:43 +0000
Subject: [PATCH 19/50] =?UTF-8?q?ensure=20we=20don=E2=80=99t=20spawn=20pri?=
 =?UTF-8?q?oritised=20processes=20using=20DispatchExtern?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 .../Process/ManagedProcess/Internal/GenProcess.hs         | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 8753c63..886ca67 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE ViewPatterns               #-}
 {-# LANGUAGE PatternGuards              #-}
 
 -- | This is the @Process@ implementation of a /managed process/
@@ -56,9 +55,10 @@ precvLoop ppDef pState recvDelay = do
     verify pDef = mapM_ disallowCC $ apiHandlers pDef
 
     -- TODO: better failure messages here!
-    disallowCC (DispatchCC _ _)  = die $ ExitOther "IllegalControlChannel"
-    disallowCC (DispatchSTM _ _) = die $ ExitOther "IllegalSTMAction"
-    disallowCC _                 = return ()
+    disallowCC (DispatchCC _ _)     = die $ ExitOther "IllegalControlChannel"
+    disallowCC (DispatchSTM _ _)    = die $ ExitOther "IllegalSTMAction"
+    disallowCC (DispatchExtern _ _) = die $ ExitOther "IllegalSTMAction"
+    disallowCC _                    = return ()
 
 recvQueue :: PrioritisedProcessDefinition s
           -> s

From 0bf42bf31fb93d4fa012f787cd03d8912a5fef87 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:48:20 +0000
Subject: [PATCH 20/50] cosmetic

---
 src/Control/Distributed/Process/ManagedProcess/Client.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 747c4d1..eac1737 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -74,7 +74,7 @@ call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult
 -- will be stashed away as @(ExitOther String)@.
 safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b)
                  => s -> a -> Process (Either ExitReason b)
-safeCall s m = initCall s m >>= waitResponse Nothing >>= return . fromJust
+safeCall s m = fmap fromJust (initCall s m >>= waitResponse Nothing)
 
 -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If
 -- you need information about *why* a call has failed then you should use
@@ -117,7 +117,7 @@ flushPendingCalls :: forall b . (Serializable b)
                   => TimeInterval
                   -> (b -> Process b)
                   -> Process (Maybe b)
-flushPendingCalls d proc = do
+flushPendingCalls d proc =
   receiveTimeout (asTimeout d) [
       match (\(CallResponse (m :: b) _) -> proc m)
     ]
@@ -135,7 +135,7 @@ callAsync server msg = async $ task $ call server msg
 --
 cast :: forall a m . (Addressable a, Serializable m)
                  => a -> m -> Process ()
-cast server msg = sendTo server ((CastMessage msg) :: T.Message m ())
+cast server msg = sendTo server (CastMessage msg :: T.Message m ())
 
 -- | Sends a /channel/ message to the server and returns a @ReceivePort@ on
 -- which the reponse can be delivered, if the server so chooses (i.e., the
@@ -144,7 +144,7 @@ callChan :: forall s a b . (Addressable s, Serializable a, Serializable b)
          => s -> a -> Process (ReceivePort b)
 callChan server msg = do
   (sp, rp) <- newChan
-  sendTo server ((ChanMessage msg sp) :: T.Message a b)
+  sendTo server (ChanMessage msg sp :: T.Message a b)
   return rp
 
 -- | A synchronous version of 'callChan'.

From a5fa5d441d98b2ead2ea5c92c3b8bb9cdfb66c67 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:49:04 +0000
Subject: [PATCH 21/50] handle server failures in callSTM a bit more robustly -
 and at least attempt to establish the monitor before evaluating the stm write
 action

---
 .../Process/ManagedProcess/Client.hs          | 54 +++++++++++++++++--
 tests/TestManagedProcess.hs                   | 27 ++++++++--
 2 files changed, 74 insertions(+), 7 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index eac1737..a590d21 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -32,13 +32,15 @@ module Control.Distributed.Process.ManagedProcess.Client
   ) where
 
 import Control.Concurrent.STM (atomically, STM)
-import Control.Distributed.Process hiding (call)
+import Control.Distributed.Process hiding (call, finally)
 import Control.Distributed.Process.Serializable
 import Control.Distributed.Process.Async hiding (check)
 import Control.Distributed.Process.ManagedProcess.Internal.Types
 import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as T
+import Control.Distributed.Process.Extras.Internal.Types (resolveOrDie)
 import Control.Distributed.Process.Extras hiding (monitor, sendChan)
 import Control.Distributed.Process.Extras.Time
+import Control.Monad.Catch (finally)
 import Data.Maybe (fromJust)
 
 import Prelude hiding (init)
@@ -164,6 +166,37 @@ syncSafeCallChan server msg = do
   rp <- callChan server msg
   awaitResponse server [ matchChan rp (return . Right) ]
 
+-- | Manages an rpc-style interaction with a server process, using @STM@ actions
+-- to read/write data. The server process is monitored for the duration of the
+-- /call/. The stm write expression is passed the input, and the read expression
+-- is evaluated and the result given as @Right b@ or @Left ExitReason@ if a
+-- monitor signal is detected whilst waiting.
+--
+-- Note that the caller will exit (with @ExitOther String@) if the server
+-- address is un-resolvable.
+--
+-- A note about scheduling and timing guarantees (or lack thereof): It is not
+-- possibly to guarantee the contents of @ExitReason@ in cases where this API
+-- fails due to server exits/crashes. We establish a monitor prior to evaluating
+-- the stm writer action, however @monitor@ is asychronous and we've no way to
+-- know whether or not the scheduler will allow monitor establishment to proceed
+-- first, or the stm transaction. As a result, assuming that your server process
+-- can die/fail/exit on evaluating the read end of the STM write we perform here
+-- (and we assume this is very likely, since we apply no safety rules and do not
+-- even worry about serialisating thunks passed from the client's thread), it is
+-- just as likely that in the case of failure you will see a reason such as
+-- @ExitOther "DiedUnknownId"@ due to the server process crashing before the node
+-- controller can establish a monitor.
+--
+-- As unpleasant as this is, there's little we can do about it without making
+-- false assumptions about the runtime. Cloud Haskell's semantics guarantee us
+-- only that we will see /some/ monitor signal in the even of a failure here.
+-- To provide a more robust error handling, you can catch/trap failures in the
+-- server process and return a wrapper reponse datum here instead. This will
+-- /still/ be subject to the failure modes described above in cases where the
+-- server process exits abnormally, but that will at least allow the caller to
+-- differentiate between expected and exceptional failure conditions.
+--
 callSTM :: forall s a b . (Addressable s)
          => s
          -> (a -> STM ())
@@ -171,5 +204,20 @@ callSTM :: forall s a b . (Addressable s)
          -> a
          -> Process (Either ExitReason b)
 callSTM server writeAction readAction input = do
-  liftIO $ atomically $ writeAction input
-  awaitResponse server [ matchSTM readAction (return . Right) ]
+    -- NB: we must establish the monitor before writing, to ensure we have
+    -- a valid ref such that server failure gets reported properly
+    pid <- resolveOrDie server "callSTM: unresolveable address "
+    mRef <- monitor pid
+
+    liftIO $ atomically $ writeAction input
+
+    finally (receiveWait [ matchRef mRef
+                         , matchSTM readAction (return . Right)
+                         ])
+            (unmonitor mRef)
+
+  where
+    matchRef :: MonitorRef -> Match (Either ExitReason b)
+    matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r')
+                         (\(ProcessMonitorNotification _ _ d) ->
+                            return (Left (ExitOther (show d))))
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index 02018c2..e513911 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -143,8 +143,8 @@ echoStm StmServer{..} = callSTM serverPid
                                 (writeTQueue writerChan)
                                 (readTQueue  readerChan)
 
-launchEchoServer :: Process StmServer
-launchEchoServer = do
+launchEchoServer :: CallHandler () String String -> Process StmServer
+launchEchoServer handler = do
   (inQ, replyQ) <- liftIO $ do
     cIn <- newTQueueIO
     cOut <- newTQueueIO
@@ -155,7 +155,7 @@ launchEchoServer = do
                     handleCallExternal
                       (readTQueue inQ)
                       (writeTQueue replyQ)
-                      (\st (msg :: String) -> reply msg st)
+                      handler
                   ]
                 }
 
@@ -165,10 +165,25 @@ launchEchoServer = do
 testExternalCall :: TestResult Bool -> Process ()
 testExternalCall result = do
   let txt = "hello stm-call foo"
-  srv <- launchEchoServer
+  srv <- launchEchoServer (\st (msg :: String) -> reply msg st)
   echoStm srv txt >>= stash result . (== Right txt)
   killProc srv "done"
 
+testExternalCallHaltingServer :: TestResult Bool -> Process ()
+testExternalCallHaltingServer result = do
+  let msg = "foo bar baz"
+  srv <- launchEchoServer (\_ (_ :: String) -> haltNoReply_ ExitNormal)
+  echoReply <- echoStm srv msg
+  case echoReply of
+    -- sadly, we cannot guarantee that our monitor will be set up fast
+    -- enough, as per the documentation!
+    Left (ExitOther reason) -> stash result $ reason `elem` [ "DiedUnknownId"
+                                                            , "DiedNormal"
+                                                            ]
+    (Left ExitNormal)       -> stash result False
+    (Left ExitShutdown)     -> stash result False
+    (Right _)               -> stash result False
+
 -- MathDemo tests
 
 testAdd :: ProcessId -> TestResult Double -> Process ()
@@ -328,6 +343,10 @@ tests transport = do
             (delayedAssertion
              "expected the server to reply back via the TQueue"
              localNode True testExternalCall)
+          , testCase "getting error data back from callSTM"
+            (delayedAssertion
+             "expected the server to exit with ExitNormal"
+             localNode True testExternalCallHaltingServer)
           , testCase "long running call cancellation"
             (delayedAssertion "expected to get AsyncCancelled"
              localNode True (testKillMidCall $ wrap server))

From 1e6a29db4992201458452bb417ec7f3149f6e9b5 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 19:52:05 +0000
Subject: [PATCH 22/50] cosmetic

---
 .../Process/ManagedProcess/Internal/Types.hs  |  2 +-
 tests/TestManagedProcess.hs                   | 25 ++++++++-----------
 2 files changed, 12 insertions(+), 15 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index a345a4c..df8d5bb 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -50,7 +50,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
-import Control.Concurrent.STM (STM, atomically)
+import Control.Concurrent.STM (STM)
 import Control.Distributed.Process hiding (Message, finally)
 import Control.Monad.Catch (finally)
 import qualified Control.Distributed.Process as P (Message)
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index e513911..30c8b89 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -1,7 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DeriveDataTypeable  #-}
-{-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE RecordWildCards     #-}
 
 module Main where
@@ -42,23 +39,23 @@ import Control.Monad.Catch (catch)
 
 -- utilities
 
-server :: Process (ProcessId, (MVar ExitReason))
+server :: Process (ProcessId, MVar ExitReason)
 server = mkServer Terminate
 
 mkServer :: UnhandledMessagePolicy
-         -> Process (ProcessId, (MVar ExitReason))
+         -> Process (ProcessId, MVar ExitReason)
 mkServer policy =
   let s = standardTestServer policy
   in do
-    exitReason <- liftIO $ newEmptyMVar
-    pid <- spawnLocal $ do
+    exitReason <- liftIO newEmptyMVar
+    pid <- spawnLocal $
        catch  ((serve () (statelessInit Infinity) s >> stash exitReason ExitNormal)
                 `catchesExit` [
                     (\_ msg -> do
                       mEx <- unwrapMessage msg :: Process (Maybe ExitReason)
                       case mEx of
                         Nothing -> return Nothing
-                        Just r  -> stash exitReason r >>= return . Just
+                        Just r  -> fmap Just (stash exitReason r)
                     )
                  ])
               (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))
@@ -69,8 +66,8 @@ explodingServer :: ProcessId
 explodingServer pid =
   let srv = explodingTestProcess pid
   in do
-    exitReason <- liftIO $ newEmptyMVar
-    spid <- spawnLocal $ do
+    exitReason <- liftIO newEmptyMVar
+    spid <- spawnLocal $
        catch  (serve () (statelessInit Infinity) srv >> stash exitReason ExitNormal)
               (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))
     return (spid, exitReason)
@@ -104,14 +101,14 @@ testChannelBasedService result =
 
 testExternalService :: TestResult Bool -> Process ()
 testExternalService result = do
-  inChan <- liftIO $ newTQueueIO
-  replyChan <- liftIO $ newTQueueIO
+  inChan <- liftIO newTQueueIO
+  replyQ <- liftIO newTQueueIO
   let procDef = statelessProcess {
                     apiHandlers = [
                       handleExternal
                         (readTQueue inChan)
                         (\s (m :: String) -> do
-                            liftIO $ atomically $ writeTQueue replyChan m
+                            liftIO $ atomically $ writeTQueue replyQ m
                             continue s)
                     ]
                     }
@@ -121,7 +118,7 @@ testExternalService result = do
     -- firstly we write something that the server can receive
     atomically $ writeTQueue inChan txt
     -- then sit and wait for it to write something back to us
-    atomically $ readTQueue replyChan
+    atomically $ readTQueue replyQ
 
   stash result (echoTxt == txt)
   kill pid "done"

From c87c39f6737578c1f2afaf16d1d05d03cfb080d1 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 22:58:25 +0000
Subject: [PATCH 23/50] upgrade to -extras-0.3.1 and remove a lot of noise

---
 .../Process/ManagedProcess/Internal/Types.hs           | 10 ----------
 stack.yaml                                             |  5 ++++-
 tests/ManagedProcessCommon.hs                          |  9 ---------
 tests/TestManagedProcess.hs                            |  4 ----
 tests/TestPrioritisedProcess.hs                        |  4 ----
 5 files changed, 4 insertions(+), 28 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index df8d5bb..ba3a0f5 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ExistentialQuantification  #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
@@ -62,7 +60,6 @@ import Control.Distributed.Process.Extras
   , Resolvable(..)
   , Routable(..)
   , NFSerializable
-  , Shutdown
   )
 import Control.Distributed.Process.Extras.Internal.Types
   ( resolveOrDie
@@ -102,7 +99,6 @@ instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where
   rnf (CastMessage a) = rnf a `seq` ()
   rnf (CallMessage a b) = rnf a `seq` rnf b `seq` ()
   rnf (ChanMessage a b) = rnf a `seq` rnf b `seq` ()
-instance (NFSerializable a, NFSerializable b) => NFSerializable (Message a b)
 deriving instance (Eq a, Eq b) => Eq (Message a b)
 deriving instance (Show a, Show b) => Show (Message a b)
 
@@ -112,7 +108,6 @@ data CallResponse a = CallResponse a CallId
 instance Serializable a => Binary (CallResponse a)
 instance NFSerializable a => NFData (CallResponse a) where
   rnf (CallResponse a c) = rnf a `seq` rnf c `seq` ()
-instance NFSerializable a => NFSerializable (CallResponse a)
 deriving instance Eq a => Eq (CallResponse a)
 deriving instance Show a => Show (CallResponse a)
 
@@ -123,11 +118,6 @@ instance Routable (CallRef a) where
   sendTo  (CallRef (client, tag)) msg = sendTo client (CallResponse msg tag)
   unsafeSendTo (CallRef (c, tag)) msg = unsafeSendTo c (CallResponse msg tag)
 
--- yuk yuk, move these back into -extras before we release...
-
-instance NFSerializable Shutdown
-instance NFSerializable ()
-
 -- | Return type for and 'InitHandler' expression.
 data InitResult s =
     InitOk s Delay {-
diff --git a/stack.yaml b/stack.yaml
index 9437c2a..9f97dba 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -6,10 +6,13 @@ packages:
     git: https://github.com/haskell-distributed/distributed-process-async.git
     commit: 7c353e52b183519c6273ef62639e55eb859cc5c8
   extra-dep: true
+- location:
+    git: https://github.com/haskell-distributed/distributed-process-extras.git
+    commit: e89c17b46225aea26634090320b2fe0926eadc77
+  extra-dep: true
 
 extra-deps:
 - network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
 - distributed-process-0.6.6         # missing snapshot
-- distributed-process-extras-0.3.0  # missing snapshot
 - distributed-process-systest-0.1.1 # missing prior to Jan-2017
 - rematch-0.2.0.0
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index ddd236e..cd15b12 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -109,9 +109,6 @@ testControlledTimeout launch result = do
   cast pid ("timeout", Delay $ within 1 Seconds)
   waitForExit exitReason >>= stash result
 
-instance NFSerializable (String, ProcessId) where
-instance NFSerializable (String, Delay) where
-
 testUnsafeControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process ()
 testUnsafeControlledTimeout launch result = do
   (pid, exitReason) <- launch ()
@@ -188,8 +185,6 @@ testDeadLetterPolicy launch result = do
     (after 5 Seconds)
     [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result
 
-instance NFSerializable (String, Int) where
-
 testUnsafeDeadLetterPolicy :: Launcher ProcessId
                      -> TestResult (Maybe (String, Int))
                      -> Process ()
@@ -247,8 +242,6 @@ testKillMidCall launch result = do
         unpack res sid AsyncCancelled = kill sid "stop" >> stash res True
         unpack res sid _              = kill sid "stop" >> stash res False
 
-instance NFSerializable (String, TimeInterval) where
-
 testUnsafeKillMidCall :: Launcher () -> TestResult Bool -> Process ()
 testUnsafeKillMidCall launch result = do
   (pid, _) <- launch ()
@@ -303,8 +296,6 @@ testAlternativeErrorHandling launch result = do
   shutdown pid
   waitForExit exitReason >>= stash result
 
-instance NFSerializable Int where
-
 testUnsafeAlternativeErrorHandling :: Launcher ProcessId
                              -> TestResult (Maybe ExitReason)
                              -> Process ()
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index 30c8b89..bc8b631 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -131,10 +131,6 @@ data StmServer = StmServer { serverPid  :: ProcessId
 instance Resolvable StmServer where
   resolve = return . Just . serverPid
 
-instance Killable StmServer where
-  killProc StmServer{..} = kill serverPid
-  exitProc StmServer{..} = exit serverPid
-
 echoStm :: StmServer -> String -> Process (Either ExitReason String)
 echoStm StmServer{..} = callSTM serverPid
                                 (writeTQueue writerChan)
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index a255182..02a9a00 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -1,10 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveDataTypeable  #-}
-{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DeriveGeneric       #-}
 
--- NB: this module contains tests for the GenProcess /and/ GenServer API.
-
 module Main where
 
 import Control.Concurrent.MVar
@@ -84,7 +81,6 @@ data MyAlarmSignal = MyAlarmSignal
   deriving (Typeable, Generic, Show, Eq)
 instance Binary MyAlarmSignal where
 instance NFData MyAlarmSignal where
-instance NFSerializable MyAlarmSignal where
 
 mkPrioritisedServer :: Process ProcessId
 mkPrioritisedServer =

From 76689d5e6cd951a7e5c93afe7c4832bb70bae684 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 20 Feb 2017 23:36:08 +0000
Subject: [PATCH 24/50] documentation

---
 .../Distributed/Process/ManagedProcess.hs     | 92 +++++++++++++++++++
 .../Process/ManagedProcess/Server.hs          |  7 ++
 2 files changed, 99 insertions(+)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 759cf1d..582b856 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -305,6 +305,98 @@
 -- >   sendControlMessage cp $ Request str sp
 -- >   receiveChan rp
 --
+-- [External (STM) Input Channels]
+--
+-- Both client and server APIs provide a mechanism for interacting with a running
+-- server process via STM. This is primarily intended for code that runs outside
+-- of Cloud Haskell's /Process/ monad, but can also be used as a channel for
+-- sending and/or receiving non-serializable data to or from a managed process.
+-- Obviously if you attempt to do this across a remote boundary, things will go
+-- spectacularly wrong. The APIs provided to not attempt to restrain this, or
+-- to impose any particular scheme on the programmer, therefore you're on your
+-- own when it comes to writing the /STM/ code for reading and writing data
+-- between client and server.
+--
+-- For code running inside the /Process/ monad and passing Serializable thunks,
+-- there is no real advantage to this approach, and indeed there are several
+-- serious disadvantages - none of Cloud Haskell's ordering guarantees will hold
+-- when passing data to and from server processes in this fashion, nor are there
+-- any guarantees the runtime system can make with regards interleaving between
+-- messages passed across Cloud Haskell's communication fabric vs. data shared
+-- via STM. This is true even when client(s) and server(s) reside on the same
+-- local node.
+--
+--
+-- A server wishing to receive data via STM can do so using the @handleExternal@
+-- API. By way of example, here is a simple echo server implemented using STM:
+--
+-- > demoExternal = do
+-- >   inChan <- liftIO newTQueueIO
+-- >   replyQ <- liftIO newTQueueIO
+-- >   let procDef = statelessProcess {
+-- >                     apiHandlers = [
+-- >                       handleExternal
+-- >                         (readTQueue inChan)
+-- >                         (\s (m :: String) -> do
+-- >                             liftIO $ atomically $ writeTQueue replyQ m
+-- >                             continue s)
+-- >                     ]
+-- >                     }
+-- >   let txt = "hello 2-way stm foo"
+-- >   pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
+-- >   echoTxt <- liftIO $ do
+-- >     -- firstly we write something that the server can receive
+-- >     atomically $ writeTQueue inChan txt
+-- >     -- then sit and wait for it to write something back to us
+-- >     atomically $ readTQueue replyQ
+-- >
+-- >   say (show $ echoTxt == txt)
+--
+-- For request/reply channels such as this, a convenience based on the call API
+-- is also provided, which allows the server author to write an ordinary call
+-- handler, and the client author to utilise an API that monitors the server and
+-- does the usual stuff you'd expect an RPC style client to do. Here is another
+-- example of this in use, demonstrating the @callSTM@ and @handleCallExternal@
+-- APIs in practise.
+--
+-- > data StmServer = StmServer { serverPid  :: ProcessId
+-- >                            , writerChan :: TQueue String
+-- >                            , readerChan :: TQueue String
+-- >                            }
+-- >
+-- > instance Resolvable StmServer where
+-- >   resolve = return . Just . serverPid
+-- >
+-- > echoStm :: StmServer -> String -> Process (Either ExitReason String)
+-- > echoStm StmServer{..} = callSTM serverPid
+-- >                                 (writeTQueue writerChan)
+-- >                                 (readTQueue  readerChan)
+-- >
+-- > launchEchoServer :: CallHandler () String String -> Process StmServer
+-- > launchEchoServer handler = do
+-- >   (inQ, replyQ) <- liftIO $ do
+-- >     cIn <- newTQueueIO
+-- >     cOut <- newTQueueIO
+-- >     return (cIn, cOut)
+-- >
+-- >   let procDef = statelessProcess {
+-- >                   apiHandlers = [
+-- >                     handleCallExternal
+-- >                       (readTQueue inQ)
+-- >                       (writeTQueue replyQ)
+-- >                       handler
+-- >                   ]
+-- >                 }
+-- >
+-- >   pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
+-- >   return $ StmServer pid inQ replyQ
+-- >
+-- > testExternalCall :: TestResult Bool -> Process ()
+-- > testExternalCall result = do
+-- >   let txt = "hello stm-call foo"
+-- >   srv <- launchEchoServer (\st (msg :: String) -> reply msg st)
+-- >   echoStm srv txt >>= stash result . (== Right txt)
+--
 -- [Performance Considerations]
 --
 -- The various server loops are fairly optimised, but there /is/ a definite
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 22141c1..7e09415 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -436,12 +436,19 @@ handleExternal :: forall s a .
     -> Dispatcher s
 handleExternal = DispatchSTM
 
+-- | Version of @handleExternal@ that ignores state.
 handleExternal_ :: forall s a .
        STM a
     -> (a -> (s -> Process (ProcessAction s)))
     -> Dispatcher s
 handleExternal_ a h = DispatchSTM a (\s m -> (h m) s)
 
+-- | Handle @call@ style API interactions using arbitrary /STM/ actions.
+--
+-- The usual @CallHandler@ is preceded by an stm action that, when evaluated,
+-- yields a value, and a second expression that is used to send a reply back
+-- to the /caller/. The corrolary client API is /callSTM/.
+--
 handleCallExternal :: forall s r w .
                       STM r
                    -> (w -> STM ())

From 358bf5c1d70e4641b32cc0be866c0357159c9b5f Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 02:30:40 +0000
Subject: [PATCH 25/50] use a new server for each test case (failing math
 server tests)

---
 tests/TestManagedProcess.hs | 32 ++++++++++++++++++--------------
 1 file changed, 18 insertions(+), 14 deletions(-)

diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index bc8b631..d60df10 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -179,14 +179,23 @@ testExternalCallHaltingServer result = do
 
 -- MathDemo tests
 
-testAdd :: ProcessId -> TestResult Double -> Process ()
-testAdd pid result = add pid 10 10 >>= stash result
+testAdd :: TestResult Double -> Process ()
+testAdd result = do
+  pid <- launchMathServer
+  add pid 10 10 >>= stash result
+  kill pid "done"
 
-testBadAdd :: ProcessId -> TestResult (Either ExitReason Int) -> Process ()
-testBadAdd pid result = safeCall pid (Add 10 10) >>= stash result
+testBadAdd :: TestResult Bool -> Process ()
+testBadAdd result = do
+  pid <- launchMathServer
+  res <- safeCall pid (Add 10 10) :: Process (Either ExitReason Int)
+  stash result (res == (Left $ ExitOther $ "DiedException \"exit-from=" ++ (show pid) ++ "\""))
 
-testDivByZero :: ProcessId -> TestResult (Either DivByZero Double) -> Process ()
-testDivByZero pid result = divide pid 125 0 >>= stash result
+testDivByZero :: TestResult (Either DivByZero Double) -> Process ()
+testDivByZero result = do
+  pid <- launchMathServer
+  divide pid 125 0 >>= stash result
+  kill pid "done"
 
 -- SafeCounter tests
 
@@ -238,9 +247,6 @@ testCounterExceedsLimit result = do
 tests :: NT.Transport  -> IO [Test]
 tests transport = do
   localNode <- newLocalNode transport initRemoteTable
-  mpid <- newEmptyMVar
-  _ <- forkProcess localNode $ launchMathServer >>= stash mpid
-  pid <- takeMVar mpid
   scpid <- newEmptyMVar
   _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid
   safeCounter <- takeMVar scpid
@@ -363,17 +369,15 @@ tests transport = do
             testCase "error (Left) returned from x / 0"
               (delayedAssertion
                "expected the server to return DivByZero"
-               localNode (Left DivByZero) (testDivByZero pid))
+               localNode (Left DivByZero) testDivByZero)
           , testCase "10 + 10 = 20"
               (delayedAssertion
                "expected the server to return DivByZero"
-               localNode 20 (testAdd pid))
+               localNode 20 testAdd)
           , testCase "10 + 10 does not evaluate to 10 :: Int at all!"
             (delayedAssertion
              "expected the server to return ExitOther..."
-             localNode
-             (Left $ ExitOther $ "DiedException \"exit-from=" ++ (show pid) ++ "\"")
-             (testBadAdd pid))
+             localNode True testBadAdd)
           ]
         , testGroup "counter server examples" [
             testCase "initial counter state = 5"

From 6b5848bcb166459921cf89ed2464ee8a6af0b0e2 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 02:56:47 +0000
Subject: [PATCH 26/50] Simplify down to one Dispatcher type

---
 .../Process/ManagedProcess/Internal/GenProcess.hs    |  1 -
 .../Process/ManagedProcess/Internal/Types.hs         | 12 ++----------
 .../Distributed/Process/ManagedProcess/Server.hs     |  6 +++---
 3 files changed, 5 insertions(+), 14 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 886ca67..459aac4 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -57,7 +57,6 @@ precvLoop ppDef pState recvDelay = do
     -- TODO: better failure messages here!
     disallowCC (DispatchCC _ _)     = die $ ExitOther "IllegalControlChannel"
     disallowCC (DispatchSTM _ _)    = die $ ExitOther "IllegalSTMAction"
-    disallowCC (DispatchExtern _ _) = die $ ExitOther "IllegalSTMAction"
     disallowCC _                    = return ()
 
 recvQueue :: PrioritisedProcessDefinition s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index ba3a0f5..7dd9dcb 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -220,7 +220,7 @@ newtype ControlChannel m =
 
 -- | Creates a new 'ControlChannel'.
 newControlChan :: (Serializable m) => Process (ControlChannel m)
-newControlChan = newChan >>= return . ControlChannel
+newControlChan = fmap ControlChannel newChan
 
 -- | The writable end of a 'ControlChannel'.
 --
@@ -263,12 +263,6 @@ data Dispatcher s =
       stmAction   :: STM a
     , stmDispatch :: s -> a -> Process (ProcessAction s)
     }
-  | forall a .
-    DispatchExtern
-    {
-      stmAction   :: STM a
-    , stmDispatch :: s -> a -> Process (ProcessAction s)
-    }
 
 -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.
 data DeferredDispatcher s =
@@ -297,7 +291,6 @@ instance MessageMatcher Dispatcher where
   matchDispatch _ s (DispatchIf  d cond)   = matchIf (cond s) (d s)
   matchDispatch _ s (DispatchCC  c d)      = matchChan c (d s)
   matchDispatch _ s (DispatchSTM c d)      = matchSTM c (d s)
-  matchDispatch _ s (DispatchExtern r d)   = matchSTM r (d s)
 
 class DynMessageHandler d where
   dynHandleMessage :: UnhandledMessagePolicy
@@ -311,7 +304,6 @@ instance DynMessageHandler Dispatcher where
   dynHandleMessage _ s (DispatchIf     d c) msg = handleMessageIf msg (c s) (d s)
   dynHandleMessage _ _ (DispatchCC     _ _) _   = error "ThisCanNeverHappen"
   dynHandleMessage _ _ (DispatchSTM    _ _) _   = error "ThisCanNeverHappen"
-  dynHandleMessage _ _ (DispatchExtern _ _) _   = error "ThisCanNeverHappen"
 
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
@@ -434,4 +426,4 @@ waitResponse mTimeout cRef =
       err r     = ExitOther $ show r in
     case mTimeout of
       (Just ti) -> finally (receiveTimeout (asTimeout ti) matchers) (unmonitor mRef)
-      Nothing   -> finally (receiveWait matchers >>= return . Just) (unmonitor mRef)
+      Nothing   -> finally (fmap Just (receiveWait matchers)) (unmonitor mRef)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 7e09415..f0eaaa0 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -455,9 +455,9 @@ handleCallExternal :: forall s r w .
                    -> CallHandler s r w
                    -> Dispatcher s
 handleCallExternal reader writer handler
-  = DispatchExtern { stmAction   = reader
-                   , stmDispatch = doStmReply handler
-                   }
+  = DispatchSTM { stmAction   = reader
+                , stmDispatch = doStmReply handler
+                }
   where
     doStmReply d s m = d s m >>= doXfmReply writer
 

From 4a7efadfcf8cd7b1080d44579c90a83827717067 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 05:34:02 +0000
Subject: [PATCH 27/50] english... [ci skip]

---
 src/Control/Distributed/Process/ManagedProcess.hs             | 4 ++--
 src/Control/Distributed/Process/ManagedProcess/Client.hs      | 4 ++--
 .../Distributed/Process/ManagedProcess/UnsafeClient.hs        | 3 +++
 3 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 582b856..2b66ed1 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -227,7 +227,7 @@
 -- 'serve', and passing an initialised 'PrioritisedProcessDefinition'.
 --
 -- Note that prioritised process definitions cannot utilise control channels,
--- not can the @handleExternal@ family of expressions be used with them. This
+-- nor can the @handleExternal@ family of expressions be used with them. This
 -- constraint is currenly not enforced by the compiler, and calling @pserve@
 -- with a @ProcessDefinition@ containing any of these items will fail with
 -- either @ExitOther "IllegalControlChannel"@ or @ExitOther "IllegalSTMAction"@
@@ -312,7 +312,7 @@
 -- of Cloud Haskell's /Process/ monad, but can also be used as a channel for
 -- sending and/or receiving non-serializable data to or from a managed process.
 -- Obviously if you attempt to do this across a remote boundary, things will go
--- spectacularly wrong. The APIs provided to not attempt to restrain this, or
+-- spectacularly wrong. The APIs provided do not attempt to restrain this, or
 -- to impose any particular scheme on the programmer, therefore you're on your
 -- own when it comes to writing the /STM/ code for reading and writing data
 -- between client and server.
diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index a590d21..a398803 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -183,14 +183,14 @@ syncSafeCallChan server msg = do
 -- first, or the stm transaction. As a result, assuming that your server process
 -- can die/fail/exit on evaluating the read end of the STM write we perform here
 -- (and we assume this is very likely, since we apply no safety rules and do not
--- even worry about serialisating thunks passed from the client's thread), it is
+-- even worry about serializing thunks passed from the client's thread), it is
 -- just as likely that in the case of failure you will see a reason such as
 -- @ExitOther "DiedUnknownId"@ due to the server process crashing before the node
 -- controller can establish a monitor.
 --
 -- As unpleasant as this is, there's little we can do about it without making
 -- false assumptions about the runtime. Cloud Haskell's semantics guarantee us
--- only that we will see /some/ monitor signal in the even of a failure here.
+-- only that we will see /some/ monitor signal in the event of a failure here.
 -- To provide a more robust error handling, you can catch/trap failures in the
 -- server process and return a wrapper reponse datum here instead. This will
 -- /still/ be subject to the failure modes described above in cases where the
diff --git a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
index b25e9a3..06feb19 100644
--- a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
@@ -166,6 +166,7 @@ callChan server msg = do
   unsafeSendTo server ((ChanMessage msg sp) :: Message a b)
   return rp
 
+  -- | A synchronous version of 'callChan'.
 syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
          => s -> a -> Process b
 syncCallChan server msg = do
@@ -174,6 +175,8 @@ syncCallChan server msg = do
     Left e   -> die e
     Right r' -> return r'
 
+-- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the
+-- call fails.
 syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
             => s -> a -> Process (Either ExitReason b)
 syncSafeCallChan server msg = do

From 7cc42173ee8e478707e3ac37580086e517b805d7 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 05:57:30 +0000
Subject: [PATCH 28/50] junk debris

---
 REPOS          |  7 -------
 test-report.hs | 10 ----------
 2 files changed, 17 deletions(-)
 delete mode 100644 REPOS
 delete mode 100755 test-report.hs

diff --git a/REPOS b/REPOS
deleted file mode 100644
index c0dcd41..0000000
--- a/REPOS
+++ /dev/null
@@ -1,7 +0,0 @@
-rank1dynamic
-distributed-static
-network-transport
-network-transport-tcp
-distributed-process
-distributed-process-extras
-distributed-process-async
diff --git a/test-report.hs b/test-report.hs
deleted file mode 100755
index 523ecf7..0000000
--- a/test-report.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-#! /bin/sh
-
-HPC_DIR=dist/hpc
-
-cabal-dev clean
-cabal-dev configure --enable-tests --enable-library-coverage
-cabal-dev build
-cabal-dev test
-
-open ${HPC_DIR}/html/*/hpc-index.html

From 2ee00f6f41b21322cceb434f8ae7bee9d78ae50e Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 05:58:36 +0000
Subject: [PATCH 29/50] re-engage travis

---
 .travis.yml           |  4 ++++
 stack-ghc-7.10.3.yaml |  9 +++++----
 stack-ghc-8.0.1.yaml  |  4 ++--
 stack.yaml            | 10 ++--------
 4 files changed, 13 insertions(+), 14 deletions(-)

diff --git a/.travis.yml b/.travis.yml
index dcdb198..ba7eaed 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -4,6 +4,10 @@ sudo: false
 
 matrix:
   include:
+  - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml" COVER="" GHCVER=7.10.3
+    addons: {apt: {packages: [libgmp-dev]}}
+  - env: ARGS="--stack-yaml stack-ghc-8.0.1.yaml" COVER="" GHCVER=8.0.1
+    addons: {apt: {packages: [libgmp-dev]}}
   - env: ARGS="--resolver nightly" COVER="" GHCVER=latest
     addons: {apt: {packages: [libgmp-dev]}}
 
diff --git a/stack-ghc-7.10.3.yaml b/stack-ghc-7.10.3.yaml
index 0629730..c96ce2c 100644
--- a/stack-ghc-7.10.3.yaml
+++ b/stack-ghc-7.10.3.yaml
@@ -2,10 +2,11 @@ resolver: nightly-2016-03-08
 
 packages:
 - '.'
-- location:
-    git: https://github.com/haskell-distributed/distributed-process-systest.git
-    commit: 6b8749fd38141425e6b677d5a5137b3fe09cc127
-  extra-dep: true
 
 extra-deps:
+- network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
 - distributed-process-0.6.6         # missing snapshot
+- distributed-process-extras-0.3.1  # missing snapshot
+- distributed-process-async-0.2.4   # missing snapshot
+- distributed-process-systest-0.1.1 # missing prior to Jan-2017
+- rematch-0.2.0.0
diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml
index e41d6ed..755e903 100644
--- a/stack-ghc-8.0.1.yaml
+++ b/stack-ghc-8.0.1.yaml
@@ -6,7 +6,7 @@ packages:
 extra-deps:
 - network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
 - distributed-process-0.6.6         # missing snapshot
-- distributed-process-extras-0.3.0  # missing snapshot
+- distributed-process-extras-0.3.1  # missing snapshot
 - distributed-process-async-0.2.4   # missing snapshot
-- distributed-process-systest-0.1.0 # missing prior to Jan-2017
+- distributed-process-systest-0.1.1 # missing prior to Jan-2017
 - rematch-0.2.0.0
diff --git a/stack.yaml b/stack.yaml
index 9f97dba..5c7887f 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,17 +2,11 @@ resolver: nightly-2017-02-03
 
 packages:
 - '.'
-- location:
-    git: https://github.com/haskell-distributed/distributed-process-async.git
-    commit: 7c353e52b183519c6273ef62639e55eb859cc5c8
-  extra-dep: true
-- location:
-    git: https://github.com/haskell-distributed/distributed-process-extras.git
-    commit: e89c17b46225aea26634090320b2fe0926eadc77
-  extra-dep: true
 
 extra-deps:
 - network-transport-inmemory-0.5.1  # snapshot 0.5.2 in lts-7.18
 - distributed-process-0.6.6         # missing snapshot
+- distributed-process-extras-0.3.1  # missing snapshot
+- distributed-process-async-0.2.4   # missing snapshot
 - distributed-process-systest-0.1.1 # missing prior to Jan-2017
 - rematch-0.2.0.0

From 936c679ffedf2acc06030011c91440a8d2339ae3 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 06:00:29 +0000
Subject: [PATCH 30/50] fix readme [ci skip]

---
 README.md | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/README.md b/README.md
index 9b20d3e..a483ece 100644
--- a/README.md
+++ b/README.md
@@ -1,14 +1,24 @@
 # distribributed-process-client-server
-[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process-client-server.png)](http://travis-ci.org/haskell-distributed/distributed-process-async)
-[![Release](https://img.shields.io/hackage/v/distributed-process-client-server.svg)](https://hackage.haskell.org/package/distributed-process-extras)
+[![Build Status](https://secure.travis-ci.org/haskell-distributed/distributed-process-client-server.png)](http://travis-ci.org/haskell-distributed/distributed-process-client-server)
+[![Code Coverage](https://coveralls.io/repos/github/haskell-distributed/distributed-process-client-server/badge.svg?branch=master)](https://coveralls.io/github/haskell-distributed/distributed-process-client-server?branch=master)
+[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29)
+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/haskell-distributed)
 
-See http://haskell-distributed.github.com for documentation, user guides,
-tutorials and assistance.
+### Releases, LTS
+Github: [![GitHub tag](https://img.shields.io/github/tag/haskell-distributed/distributed-process-client-server.svg)]() [![GitHub commits](https://img.shields.io/github/commits-since/haskell-distributed/distributed-process-client-server/release-0.2.1.svg)]()
 
-## Getting Help / Raising Issues
+Hackage: [![Releases](https://img.shields.io/hackage/v/distributed-process-client-server.svg)](https://hackage.haskell.org/package/distributed-process-client-server) [![Dependencies](https://img.shields.io/hackage-deps/v/distributed-process-client-server.svg)](http://packdeps.haskellers.com/feed?needle=distributed-process-client-server)
 
-Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-client-server/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.
+Stackage: [![LTS 6](https://www.stackage.org/package/distributed-process-client-server/badge/lts-6)](http://stackage.org/lts-6/package/distributed-process-client-server)
+[![NIGHTLY](https://www.stackage.org/package/distributed-process-client-server/badge/nightly)](http://stackage.org/nightly/package/distributed-process-client-server)
 
-## License
+### Getting Help / Raising Issues
+[![Slack Sign Up/In](https://rauchg-slackin-dxinpkuzrg.now.sh/badge.svg)](https://rauchg-slackin-dxinpkuzrg.now.sh/) [![Slack Sign Up/In](https://img.shields.io/badge/Freenode-%23haskell--distributed-ff69b4.svg)]()
+
+As well as our Slack channels (you'll need to sign up, but there is a form for doing so) and #haskell-distributed on freenode, you can contact the distributed-haskell@googlegroups.com mailing list for help and comments. Please also see http://haskell-distributed.github.com for documentation, user guides, tutorials and assistance.
+
+Visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-client-server/issues) to submit issues.
+
+### License
 
 This package is made available under a 3-clause BSD-style license.

From 5f2c5bb0e8a3ae1326acd73d4910b9eae4125ac1 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 12:12:10 +0000
Subject: [PATCH 31/50] Tighten up exception handling in safeCall - fixes #8

---
 .../Process/ManagedProcess/Client.hs          | 35 +++++++++++++++++--
 1 file changed, 32 insertions(+), 3 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index a398803..4982d73 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -72,15 +72,44 @@ call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult
         decodeResult Nothing {- the impossible happened -} = terminate
 
 -- | Safe version of 'call' that returns information about the error
--- if the operation fails. If an error occurs then the explanation will be
--- will be stashed away as @(ExitOther String)@.
+-- if the operation fails. If the calling process dies (that is, forces itself
+-- to exit such that an exit signal arises with @ExitOther String@) then
+-- evaluation will return @Left exitReason@ and the explanation will be
+-- stashed away as @(ExitOther String)@.
+--
+-- __NOTE: this function does not catch exceptions!__
+--
+-- The /safety/ of the name, comes from carefully handling situations in which
+-- the server dies while we're waiting for a reply. Notably, exit signals from
+-- other processes, kill signals, and both synchronous and asynchronous
+-- exceptions can still terminate the caller abruptly. To avoid this consider
+-- masking or evaluating within your own exception handling code.
+--
 safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b)
                  => s -> a -> Process (Either ExitReason b)
-safeCall s m = fmap fromJust (initCall s m >>= waitResponse Nothing)
+safeCall s m = do
+  us <- getSelfPid
+  (fmap fromJust (initCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b))
+    `catchesExit` [(\pid msg -> handleMessageIf msg (weFailed pid us)
+                                                    (return . Left))]
+
+  where
+
+    weFailed a b (ExitOther _) = a == b
+    weFailed _ _ _             = False
 
 -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If
 -- you need information about *why* a call has failed then you should use
 -- 'safeCall' or combine @catchExit@ and @call@ instead.
+--
+-- __NOTE: this function does not catch exceptions!__
+--
+-- In fact, this API handles fewer exceptions than it's relative, "safeCall".
+-- Notably, exit signals, kill signals, and both synchronous and asynchronous
+-- exceptions can still terminate the caller abruptly. To avoid this consider
+-- masking or evaluating within your own exception handling code (as mentioned
+-- above).
+--
 tryCall :: forall s a b . (Addressable s, Serializable a, Serializable b)
                  => s -> a -> Process (Maybe b)
 tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult

From 3f41456319c3e0361d85245675e6bbe702089722 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 18:32:18 +0000
Subject: [PATCH 32/50] =?UTF-8?q?fix(PrioritisedProcess):=20use=20RecvTime?=
 =?UTF-8?q?outPolicy=20to=20ensure=20we=20don=E2=80=99t=20get=20stuck=20re?=
 =?UTF-8?q?ading=20a=20busy=20mailbox?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Fixes #12
---
 .../ManagedProcess/Internal/GenProcess.hs     | 82 +++++++++++++------
 tests/TestPrioritisedProcess.hs               | 62 +++++++++++++-
 2 files changed, 118 insertions(+), 26 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 459aac4..efd700e 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 
 -- | This is the @Process@ implementation of a /managed process/
 module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
@@ -33,6 +35,7 @@ import Control.Distributed.Process.Extras.Timer
   , TimerRef
   )
 import Control.Monad (void)
+import Data.Typeable (Typeable)
 import Prelude hiding (init)
 
 --------------------------------------------------------------------------------
@@ -43,14 +46,16 @@ import Prelude hiding (init)
 -- that a busy mailbox can't prevent us from operating normally.
 
 type Queue = PriorityQ Int P.Message
-type TimeoutSpec = (Delay, Maybe (TimerRef, (STM ())))
+type TimeoutSpec = (Delay, Maybe (TimerRef, STM ()))
 data TimeoutAction s = Stop s ExitReason | Go Delay s
 
+data CancelTimer = CancelTimer deriving (Eq, Show, Typeable)
+
 precvLoop :: PrioritisedProcessDefinition s -> s -> Delay -> Process ExitReason
 precvLoop ppDef pState recvDelay = do
     void $ verify $ processDef ppDef
     tref <- startTimer recvDelay
-    recvQueue ppDef pState tref $ PriorityQ.empty
+    recvQueue ppDef pState tref PriorityQ.empty
   where
     verify pDef = mapM_ disallowCC $ apiHandlers pDef
 
@@ -81,10 +86,11 @@ recvQueue p s t q =
       | otherwise {- compiler foo -} = die "IllegalState"
 
     recvQueueAux ppDef prioritizers pState delay queue =
-      let ex = (trapExit:(exitHandlers $ processDef ppDef))
+      let ex = trapExit:(exitHandlers $ processDef ppDef)
           eh = map (\d' -> (dispatchExit d') pState) ex
+          mx = recvTimeout ppDef
       in (do t' <- startTimer delay
-             mq <- drainMessageQueue pState prioritizers queue
+             mq <- drainMessageQueue mx pState prioritizers queue
              recvQueue ppDef pState t' mq)
          `catchExit`
          (\pid (reason :: ExitReason) -> do
@@ -114,23 +120,23 @@ recvQueue p s t q =
         Just pa -> return (pa, Infinity, pq)
 
     processNext def ps' pState tSpec queue =
-      let ex = (trapExit:(exitHandlers def))
+      let ex = trapExit:(exitHandlers def)
           h  = timeoutHandler def in do
         -- as a side effect, this check will cancel the timer
         timedOut <- checkTimer pState tSpec h
         case timedOut of
-          Stop s' r -> return $ (ProcessStopping s' r, (fst tSpec), queue)
-          Go t' s'  -> do
+          Stop s' r -> return (ProcessStopping s' r, (fst tSpec), queue)
+          Go t' s'  ->
             -- checkTimer could've run our timeoutHandler, which changes "s"
-            case (dequeue queue) of
-              Nothing -> do
+            case dequeue queue of
+              Nothing ->
                 -- if the internal queue is empty, we fall back to reading the
                 -- actual mailbox, however if /that/ times out, then we need
                 -- to let the timeout handler kick in again and make a decision
                 drainOrTimeout s' t' queue ps' h
               Just (m', q') -> do
                 act <- catchesExit (processApply def s' m')
-                                   (map (\d' -> (dispatchExit d') s') ex)
+                                   (map (\d' -> dispatchExit d' s') ex)
                 return (act, t', q')
 
     processApply def pState msg =
@@ -148,30 +154,60 @@ recvQueue p s t q =
         Nothing  -> processApplyAux hs p' s' m'
         Just act -> return act
 
-    drainOrTimeout pState delay queue ps' h = do
+    drainOrTimeout pState delay queue ps' h =
       let matches = [ matchMessage return ]
           recv    = case delay of
-                      Infinity -> receiveWait matches >>= return . Just
+                      Infinity -> fmap Just (receiveWait matches)
                       NoDelay  -> receiveTimeout 0 matches
                       Delay i  -> receiveTimeout (asTimeout i) matches in do
         r <- recv
         case r of
-          Nothing -> h pState delay >>= \act -> return $ (act, delay, queue)
+          Nothing -> h pState delay >>= \act -> return (act, delay, queue)
           Just m  -> do
             queue' <- enqueueMessage pState ps' m queue
             -- Returning @ProcessContinue@ simply causes the main loop to go
             -- into 'recvQueueAux', which ends up in 'drainMessageQueue'.
             -- In other words, we continue draining the /real/ mailbox.
-            return $ (ProcessContinue pState, delay, queue')
-
-drainMessageQueue :: s -> [DispatchPriority s] -> Queue -> Process Queue
-drainMessageQueue pState priorities' queue = do
-  m <- receiveTimeout 0 [ matchMessage return ]
-  case m of
-    Nothing -> return queue
-    Just m' -> do
-      queue' <- enqueueMessage pState priorities' m' queue
-      drainMessageQueue pState priorities' queue'
+            return (ProcessContinue pState, delay, queue')
+
+drainMessageQueue :: RecvTimeoutPolicy
+                  -> s
+                  -> [DispatchPriority s]
+                  -> Queue
+                  -> Process Queue
+drainMessageQueue limit pState priorities' queue = do
+    timerAcc <- case limit of
+                  RecvTimer   tm  -> setupTimer tm
+                  RecvCounter cnt -> return $ Right cnt
+    drainMessageQueueAux timerAcc pState priorities' queue
+
+  where
+
+    drainMessageQueueAux acc st ps q = do
+      (acc', m) <- drainIt acc
+      -- say $ "drained " ++ show m
+      case m of
+        Nothing                 -> return q
+        Just (Left CancelTimer) -> return q
+        Just (Right m')         -> do
+          queue' <- enqueueMessage st ps m' q
+          drainMessageQueueAux acc' st ps queue'
+
+    drainIt :: Either (STM CancelTimer) Int
+            -> Process (Either (STM CancelTimer) Int,
+                        Maybe (Either CancelTimer P.Message))
+    drainIt e@(Right 0)  = return (e, Just (Left CancelTimer))
+    drainIt (Right cnt)  = fmap (Right $ cnt - 1, )
+                                (receiveTimeout 0 [ matchAny (return . Right) ])
+    drainIt a@(Left stm) = fmap (a, )
+                                (receiveTimeout 0 [ matchSTM stm (return . Left)
+                                                  , matchAny     (return . Right)
+                                                  ])
+
+    setupTimer intv = do
+      chan <- liftIO newTChanIO
+      void $ runAfter intv $ liftIO $ atomically $ writeTChan chan CancelTimer
+      return $ Left (readTChan chan)
 
 enqueueMessage :: s
                -> [DispatchPriority s]
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 02a9a00..0196bc7 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -66,7 +66,7 @@ explodingServer pid =
   let srv = explodingTestProcess pid
       pSrv = srv `prioritised` ([] :: [DispatchPriority s])
   in do
-    exitReason <- liftIO $ newEmptyMVar
+    exitReason <- liftIO newEmptyMVar
     spid <- spawnLocal $ do
        catch  (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal)
               (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))
@@ -113,7 +113,57 @@ mkPrioritisedServer =
           , timeoutHandler         = \_ _ -> stop $ ExitOther "timeout"
           } :: ProcessDefinition [(Either MyAlarmSignal String)]
 
--- test cases
+mkOverflowHandlingServer :: (PrioritisedProcessDefinition Int ->
+                             PrioritisedProcessDefinition Int)
+                         -> Process ProcessId
+mkOverflowHandlingServer modIt =
+  let p = procDef `prioritised` ([
+               prioritiseCall_ (\GetState -> setPriority 99 :: Priority Int)
+             , prioritiseCast_ (\(_ :: String) -> setPriority 1)
+             ] :: [DispatchPriority Int]
+          ) :: PrioritisedProcessDefinition Int
+  in spawnLocal $ pserve () (initWait Infinity) (modIt p)
+  where
+    initWait :: Delay
+             -> InitHandler () Int
+    initWait d () = return $ InitOk 0 d
+
+    procDef :: ProcessDefinition Int
+    procDef =
+      defaultProcess {
+            apiHandlers = [
+               handleCall (\s GetState -> reply s s)
+             , handleCast (\s (_ :: String) -> continue $ s + 1)
+            ]
+          } :: ProcessDefinition Int
+
+testTimedOverflowHandling :: TestResult Bool -> Process ()
+testTimedOverflowHandling result = do
+  pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvTimer $ within 3 Seconds })
+  wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..500000] :: [Int])
+
+  sleep $ seconds 1 -- give the worker time to start spamming us...
+  cast pid "abc" -- just getting in line here...
+
+  st <- call pid GetState :: Process Int
+  -- the result of GetState is a list of messages in reverse insertion order
+  stash result $ st > 0
+  kill wrk "done"
+  kill pid "done"
+
+testOverflowHandling :: TestResult Bool -> Process ()
+testOverflowHandling result = do
+  pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvCounter 100 })
+  wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..50000] :: [Int])
+
+  sleep $ seconds 1
+  cast pid "abc" -- just getting in line here...
+
+  st <- call pid GetState :: Process Int
+  -- the result of GetState is a list of messages in reverse insertion order
+  stash result $ st > 0
+  kill wrk "done"
+  kill pid "done"
 
 testInfoPrioritisation :: TestResult Bool -> Process ()
 testInfoPrioritisation result = do
@@ -149,7 +199,7 @@ testCallPrioritisation result = do
   -- is undefined (and in practise, paritally depenendent on the scheduler)
   sleep $ seconds 1
   send pid ()
-  mapM wait asyncRefs :: Process [AsyncResult ()]
+  _ <- mapM wait asyncRefs :: Process [AsyncResult ()]
   st <- call pid GetState :: Process [Either MyAlarmSignal String]
   let ms = rights st
   stash result $ ms == ["we do prioritise", "the longest", "commands", "first"]
@@ -210,6 +260,12 @@ tests transport = do
           , testCase "Call Message Prioritisation"
             (delayedAssertion "expected the longest strings to be prioritised"
              localNode True testCallPrioritisation)
+          , testCase "Size-Based Mailbox Overload Management"
+            (delayedAssertion "expected the server loop to stop reading the mailbox"
+             localNode True testOverflowHandling)
+          , testCase "Timeout-Based Mailbox Overload Management"
+            (delayedAssertion "expected the server loop to stop reading the mailbox"
+             localNode True testTimedOverflowHandling)
           ]
       ]
 

From bfc005a7179b0fab79a58361f585b1f1e4cc9701 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 18:41:58 +0000
Subject: [PATCH 33/50] Update copyright

---
 distributed-process-client-server.cabal                         | 2 +-
 src/Control/Distributed/Process/ManagedProcess.hs               | 2 +-
 src/Control/Distributed/Process/ManagedProcess/Client.hs        | 2 +-
 src/Control/Distributed/Process/ManagedProcess/Server.hs        | 2 +-
 .../Distributed/Process/ManagedProcess/Server/Restricted.hs     | 2 +-
 src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs  | 2 +-
 6 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 14a0a16..3773351 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -5,7 +5,7 @@ build-type:     Simple
 license:        BSD3
 license-file:   LICENCE
 stability:      experimental
-Copyright:      Tim Watson 2012 - 2013
+Copyright:      Tim Watson 2012 - 2017
 Author:         Tim Watson
 Maintainer:     Tim Watson <watson.timothy@gmail.com>
 Stability:      experimental
diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 2b66ed1..4b29436 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -4,7 +4,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Distributed.Process.ManagedProcess
--- Copyright   :  (c) Tim Watson 2012
+-- Copyright   :  (c) Tim Watson 2012 - 2017
 -- License     :  BSD3 (see the file LICENSE)
 --
 -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 4982d73..648cfc6 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -4,7 +4,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Distributed.Process.ManagedProcess.Client
--- Copyright   :  (c) Tim Watson 2012 - 2013
+-- Copyright   :  (c) Tim Watson 2012 - 2017
 -- License     :  BSD3 (see the file LICENSE)
 --
 -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 6d1b157..a12f240 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -4,7 +4,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Distributed.Process.ManagedProcess.Server
--- Copyright   :  (c) Tim Watson 2012 - 2013
+-- Copyright   :  (c) Tim Watson 2012 - 2017
 -- License     :  BSD3 (see the file LICENSE)
 --
 -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index feb1d9f..78fe51f 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -6,7 +6,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Distributed.Process.ManagedProcess.Server.Restricted
--- Copyright   :  (c) Tim Watson 2012 - 2013
+-- Copyright   :  (c) Tim Watson 2012 - 2017
 -- License     :  BSD3 (see the file LICENSE)
 --
 -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
diff --git a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
index 06feb19..c7f9b7a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
@@ -5,7 +5,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Distributed.Process.ManagedProcess.UnsafeClient
--- Copyright   :  (c) Tim Watson 2012 - 2013
+-- Copyright   :  (c) Tim Watson 2012 - 2017
 -- License     :  BSD3 (see the file LICENSE)
 --
 -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>

From 8c71b4eba223a954ee82e94e0474943c620af2c6 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 18:42:31 +0000
Subject: [PATCH 34/50] Fix safeCall in UnsafeClient

---
 .../Process/ManagedProcess/UnsafeClient.hs       | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
index c7f9b7a..7b9ea14 100644
--- a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
@@ -62,6 +62,9 @@ import Control.Distributed.Process
   , terminate
   , receiveTimeout
   , unsafeSendChan
+  , getSelfPid
+  , catchesExit
+  , handleMessageIf
   )
 import Control.Distributed.Process.Async
   ( Async
@@ -73,7 +76,7 @@ import Control.Distributed.Process.Extras
   , Addressable
   , Routable(..)
   , NFSerializable
-  , ExitReason
+  , ExitReason(..)
   , Shutdown(..)
   )
 import Control.Distributed.Process.ManagedProcess.Internal.Types
@@ -113,7 +116,16 @@ call sid msg = unsafeInitCall sid msg >>= waitResponse Nothing >>= decodeResult
 -- if the operation fails - uses /unsafe primitives/.
 safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
                  => s -> a -> Process (Either ExitReason b)
-safeCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= return . fromJust
+safeCall s m = do
+  us <- getSelfPid
+  (fmap fromJust (unsafeInitCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b))
+    `catchesExit` [(\pid msg -> handleMessageIf msg (weFailed pid us)
+                                                    (return . Left))]
+
+  where
+
+    weFailed a b (ExitOther _) = a == b
+    weFailed _ _ _             = False
 
 -- | Version of 'safeCall' that returns 'Nothing' if the operation fails.
 --  Uses /unsafe primitives/.

From 9cdfddfabafca026960ac26363ec19281a5083b1 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 18:42:43 +0000
Subject: [PATCH 35/50] Cosmetic

---
 .../Distributed/Process/ManagedProcess/Server/Restricted.hs      | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index 78fe51f..04db47c 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -266,4 +266,3 @@ runRestricted state proc = ST.runStateT (unRestricted proc) state
 -- | TODO MonadTrans instance? lift :: (Monad m) => m a -> t m a
 lift :: Process a -> RestrictedProcess s a
 lift p = RestrictedProcess $ ST.lift p
-

From 0871f0f6619132f44f7b5a58ab6c6507e721915b Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 18:43:07 +0000
Subject: [PATCH 36/50] Update bounds and increment version

---
 distributed-process-client-server.cabal | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 3773351..9b165b7 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -1,5 +1,5 @@
 name:           distributed-process-client-server
-version:        0.1.3.2
+version:        0.2.0
 cabal-version:  >=1.8
 build-type:     Simple
 license:        BSD3
@@ -17,7 +17,7 @@ description:    Modelled after Erlang OTP's gen_server, this framework provides
                 development into a set of modules and standards designed to help you build
                 concurrent, distributed applications with relative ease.
 category:       Control
-tested-with:    GHC == 7.4.2 GHC == 7.6.2 GHC == 8.0.1
+Tested-With:    GHC==7.10.3 GHC==8.0.1 GHC==8.0.2
 data-dir:       ""
 
 source-repository head
@@ -29,8 +29,8 @@ library
                    base >= 4.4 && < 5,
                    data-accessor >= 0.2.2.3,
                    distributed-process >= 0.6.6 && < 0.7,
-                   distributed-process-extras >= 0.3.0 && < 0.4,
-                   distributed-process-async >= 0.2.3 && < 0.3,
+                   distributed-process-extras >= 0.3.1 && < 0.4,
+                   distributed-process-async >= 0.2.4 && < 0.3,
                    binary >= 0.6.3.0 && < 0.9,
                    deepseq >= 1.3.0.1 && < 1.6,
                    mtl,
@@ -69,8 +69,8 @@ test-suite ManagedProcessTests
                    ansi-terminal >= 0.5 && < 0.7,
                    containers,
                    distributed-process >= 0.6.6 && < 0.7,
-                   distributed-process-extras >= 0.3.0 && < 0.4,
-                   distributed-process-async >= 0.2.3 && < 0.3,
+                   distributed-process-extras >= 0.3.1 && < 0.4,
+                   distributed-process-async >= 0.2.4 && < 0.3,
                    distributed-process-client-server,
                    distributed-process-systest >= 0.1.1 && < 0.2,
                    network-transport >= 0.4 && < 0.5,
@@ -102,8 +102,8 @@ test-suite PrioritisedProcessTests
                    ansi-terminal >= 0.5 && < 0.7,
                    containers,
                    distributed-process >= 0.6.6 && < 0.7,
-                   distributed-process-extras >= 0.3.0 && < 0.4,
-                   distributed-process-async >= 0.2.3 && < 0.3,
+                   distributed-process-extras >= 0.3.1 && < 0.4,
+                   distributed-process-async >= 0.2.4 && < 0.3,
                    distributed-process-client-server,
                    distributed-process-systest >= 0.1.1 && < 0.2,
                    network-transport >= 0.4 && < 0.5,

From 31fb9064690d9483a346b20c7d20e06a41c183c5 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 23:14:46 +0000
Subject: [PATCH 37/50] =?UTF-8?q?Don=E2=80=99t=20depend=20on=20data-access?=
 =?UTF-8?q?or?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 distributed-process-client-server.cabal | 1 -
 1 file changed, 1 deletion(-)

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index 9b165b7..b82c3b4 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -27,7 +27,6 @@ source-repository head
 library
   build-depends:
                    base >= 4.4 && < 5,
-                   data-accessor >= 0.2.2.3,
                    distributed-process >= 0.6.6 && < 0.7,
                    distributed-process-extras >= 0.3.1 && < 0.4,
                    distributed-process-async >= 0.2.4 && < 0.3,

From c850b29980346a446f864b21478d9a4b7540c189 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 21 Feb 2017 23:15:29 +0000
Subject: [PATCH 38/50] tidy and add missing haddocks

---
 .../Distributed/Process/ManagedProcess.hs     |  9 +++
 .../ManagedProcess/Internal/GenProcess.hs     | 20 +++++++
 .../Process/ManagedProcess/Internal/Types.hs  | 16 ++++-
 .../Process/ManagedProcess/Server.hs          | 58 ++++---------------
 .../Process/ManagedProcess/Server/Priority.hs | 38 ++++++++----
 .../ManagedProcess/Server/Restricted.hs       | 10 ++--
 .../Process/ManagedProcess/UnsafeClient.hs    |  9 +--
 7 files changed, 93 insertions(+), 67 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 4b29436..b9c592c 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -444,8 +444,17 @@ module Control.Distributed.Process.ManagedProcess
   , ProcessAction(..)
   , ProcessReply
   , Condition
+  , Action
+  , Reply
+  , ActionHandler
   , CallHandler
   , CastHandler
+  , StatelessHandler
+  , DeferredCallHandler
+  , StatelessCallHandler
+  , InfoHandler
+  , ChannelHandler
+  , StatelessChannelHandler
   , UnhandledMessagePolicy(..)
   , CallRef
   , ControlChannel()
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index efd700e..8e2e1e6 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -51,6 +51,16 @@ data TimeoutAction s = Stop s ExitReason | Go Delay s
 
 data CancelTimer = CancelTimer deriving (Eq, Show, Typeable)
 
+-- | Prioritised process loop.
+--
+-- Evaluating this function will cause the caller to enter a server loop,
+-- constantly reading messages from its mailbox (and/or other supplied control
+-- planes) and passing these to handler functions in the supplied process
+-- definition. Only when it is determined that the server process should
+-- terminate - either by the handlers deciding to stop the process, or by an
+-- unhandled exit signal or other form of failure condition (e.g. synchronous or
+-- asynchronous exceptions).
+--
 precvLoop :: PrioritisedProcessDefinition s -> s -> Delay -> Process ExitReason
 precvLoop ppDef pState recvDelay = do
     void $ verify $ processDef ppDef
@@ -231,6 +241,16 @@ enqueueMessage s (p:ps) m' q = let checkPrio = prioritise p s in do
 -- Ordinary/Blocking Mailbox Handling                                         --
 --------------------------------------------------------------------------------
 
+-- | Managed process loop.
+--
+-- Evaluating this function will cause the caller to enter a server loop,
+-- constantly reading messages from its mailbox (and/or other supplied control
+-- planes) and passing these to handler functions in the supplied process
+-- definition. Only when it is determined that the server process should
+-- terminate - either by the handlers deciding to stop the process, or by an
+-- unhandled exit signal or other form of failure condition (e.g. synchronous or
+-- asynchronous exceptions).
+--
 recvLoop :: ProcessDefinition s -> s -> Delay -> Process ExitReason
 recvLoop pDef pState recvDelay =
   let p             = unhandledMessagePolicy pDef
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 3aab5bc..a158a2f 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -81,17 +81,21 @@ import GHC.Generics
 -- API                                                                        --
 --------------------------------------------------------------------------------
 
+-- | wrapper for a @MonitorRef@
 type CallId = MonitorRef
 
+-- | Wraps a consumer of the call API
 newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }
   deriving (Eq, Show, Typeable, Generic)
 
 instance Binary (CallRef a) where
 instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
 
+-- | Creates a @CallRef@ for the given @Recipient@ and @CallId@
 makeRef :: Recipient -> CallId -> CallRef a
 makeRef r c = CallRef (r, c)
 
+-- | @Message@ type used internally by the call, cast, and rpcChan APIs.
 data Message a b =
     CastMessage a
   | CallMessage a (CallRef b)
@@ -106,6 +110,7 @@ instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where
 deriving instance (Eq a, Eq b) => Eq (Message a b)
 deriving instance (Show a, Show b) => Show (Message a b)
 
+-- | Response type for the call API
 data CallResponse a = CallResponse a CallId
   deriving (Typeable, Generic)
 
@@ -162,11 +167,11 @@ data Condition s m =
   | Input     (m -> Bool)       -- ^ predicated on the input message only
 
 
--- | Yielding an action (server state transition) in the @Process@ monad
+-- | An action (server state transition) in the @Process@ monad
 type Action s = Process (ProcessAction s)
 
--- | Yielding an action (server state transition) whilst also replying to a
--- caller, in the @Process@ monad
+-- | An action (server state transition) causing a reply to a  caller, in the
+-- @Process@ monad
 type Reply b s = Process (ProcessReply b s)
 
 -- | An expression used to handle a message
@@ -281,6 +286,7 @@ data ExitSignalDispatcher s =
                  -> Process (Maybe (ProcessAction s))
   }
 
+-- | Defines the means of dispatching inbound messages to a handler
 class MessageMatcher d where
   matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)
 
@@ -290,6 +296,8 @@ instance MessageMatcher Dispatcher where
   matchDispatch _ s (DispatchCC  c d)      = matchChan c (d s)
   matchDispatch _ s (DispatchSTM c d)      = matchSTM c (d s)
 
+-- | Maps handlers to a dynamic action that can take place outside of a
+-- expect/recieve block.
 class DynMessageHandler d where
   dynHandleMessage :: UnhandledMessagePolicy
                    -> s
@@ -306,8 +314,10 @@ instance DynMessageHandler Dispatcher where
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
 
+-- | Priority of a message, encoded as an @Int@
 newtype Priority a = Priority { getPrio :: Int }
 
+-- | Dispatcher for prioritised handlers
 data DispatchPriority s =
     PrioritiseCall
     {
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index a12f240..74296a9 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -232,17 +232,10 @@ handleCallIf_ :: forall s a b . (Serializable a, Serializable b)
     -> Dispatcher s
 handleCallIf_ cond handler
   = DispatchIf {
-      dispatch   = doHandle handler
+      dispatch   = \s (CallMessage p c) -> handler p >>= mkCallReply c s
     , dispatchIf = checkCall cond
     }
-  where doHandle :: (Serializable a, Serializable b)
-                 => (a -> Process b)
-                 -> s
-                 -> Message a b
-                 -> Process (ProcessAction s)
-        doHandle h s (CallMessage p c) = h p >>= mkCallReply c s
-        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]
-
+  where
         -- handling 'reply-to' in the main process loop is awkward at best,
         -- so we handle it here instead and return the 'action' to the loop
         mkCallReply :: (Serializable b)
@@ -274,17 +267,10 @@ handleCallIf :: forall s a b . (Serializable a, Serializable b)
         -- ^ a reply yielding function over the process state and input message
     -> Dispatcher s
 handleCallIf cond handler
-  = DispatchIf {
-      dispatch   = doHandle handler
+  = DispatchIf
+    { dispatch   = \s (CallMessage p c) -> handler s p >>= mkReply c
     , dispatchIf = checkCall cond
     }
-  where doHandle :: (Serializable a, Serializable b)
-                 => CallHandler s a b
-                 -> s
-                 -> Message a b
-                 -> Process (ProcessAction s)
-        doHandle h s (CallMessage p c) = h s p >>= mkReply c
-        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]
 
 -- | A variant of 'handleCallFrom_' that ignores the state argument.
 --
@@ -299,18 +285,11 @@ handleCallFromIf_ :: forall s a b . (Serializable a, Serializable b)
                   => Condition s a
                   -> StatelessCallHandler s a b
                   -> Dispatcher s
-handleCallFromIf_ c h =
+handleCallFromIf_ cond handler =
   DispatchIf {
-      dispatch   = doHandle h
-    , dispatchIf = checkCall c
+      dispatch   = \_ (CallMessage p c) -> handler c p >>= mkReply c
+    , dispatchIf = checkCall cond
     }
-  where doHandle :: (Serializable a, Serializable b)
-                 => (CallRef b -> a -> Process (ProcessReply b s))
-                 -> s
-                 -> Message a b
-                 -> Process (ProcessAction s)
-        doHandle h' _ (CallMessage p c') = h' c' p >>= mkReply c'
-        doHandle _  _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]
 
 -- | As 'handleCall' but passes the 'CallRef' to the handler function.
 -- This can be useful if you wish to /reply later/ to the caller by, e.g.,
@@ -333,16 +312,9 @@ handleCallFromIf :: forall s a b . (Serializable a, Serializable b)
     -> Dispatcher s
 handleCallFromIf cond handler
   = DispatchIf {
-      dispatch   = doHandle handler
+      dispatch   = \s (CallMessage p c) -> handler c s p >>= mkReply c
     , dispatchIf = checkCall cond
     }
-  where doHandle :: (Serializable a, Serializable b)
-                 => (CallRef b -> CallHandler s a b)
-                 -> s
-                 -> Message a b
-                 -> Process (ProcessAction s)
-        doHandle h s (CallMessage p c) = h c s p >>= mkReply c
-        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]
 
 -- | Creates a handler for a /typed channel/ RPC style interaction. The
 -- handler takes a @SendPort b@ to reply to, the initial input and evaluates
@@ -361,18 +333,11 @@ handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)
                 => Condition s a
                 -> ChannelHandler s a b
                 -> Dispatcher s
-handleRpcChanIf c h
+handleRpcChanIf cond handler
   = DispatchIf {
-      dispatch   = doHandle h
-    , dispatchIf = checkRpc c
+      dispatch   = \s (ChanMessage p c) -> handler c s p
+    , dispatchIf = checkRpc cond
     }
-  where doHandle :: (Serializable a, Serializable b)
-                 => ChannelHandler s a b
-                 -> s
-                 -> Message a b
-                 -> Process (ProcessAction s)
-        doHandle h' s (ChanMessage p c') = h' c' s p
-        doHandle _  _ _ = die "RPC_HANDLER_TYPE_MISMATCH" -- node [Message type]
 
 -- | A variant of 'handleRpcChan' that ignores the state argument.
 --
@@ -600,6 +565,7 @@ handleExit h = ExitSignalDispatcher { dispatchExit = doHandleExit h }
                  -> Process (Maybe (ProcessAction s))
     doHandleExit h' s p msg = handleMessage msg (h' p s)
 
+-- | Conditional version of @handleExit@
 handleExitIf :: forall s a . (Serializable a)
              => (s -> a -> Bool)
              -> (ProcessId -> ActionHandler s a)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index be79c72..edf1bb0 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -2,6 +2,18 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE PatternGuards              #-}
 
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Distributed.Process.ManagedProcess.Server.Priority
+-- Copyright   :  (c) Tim Watson 2012 - 2017
+-- License     :  BSD3 (see the file LICENSE)
+--
+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (requires concurrency)
+--
+-- The Prioritised Server portion of the /Managed Process/ API.
+-----------------------------------------------------------------------------
 module Control.Distributed.Process.ManagedProcess.Server.Priority
   ( prioritiseCall
   , prioritiseCall_
@@ -18,21 +30,24 @@ import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Serializable
 import Prelude hiding (init)
 
+-- | Sets an explicit priority
 setPriority :: Int -> Priority m
 setPriority = Priority
 
+-- | Prioritise a call handler, ignoring the server's state
 prioritiseCall_ :: forall s a b . (Serializable a, Serializable b)
                 => (a -> Priority b)
                 -> DispatchPriority s
-prioritiseCall_ h = prioritiseCall (\_ -> h)
+prioritiseCall_ h = prioritiseCall (const h)
 
+-- | Prioritise a call handler
 prioritiseCall :: forall s a b . (Serializable a, Serializable b)
                => (s -> a -> Priority b)
                -> DispatchPriority s
-prioritiseCall h = PrioritiseCall (\s -> unCall $ h s)
+prioritiseCall h = PrioritiseCall (unCall . h)
   where
     unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message))
-    unCall h' m = unwrapMessage m >>= return . matchPrioritise m h'
+    unCall h' m = fmap (matchPrioritise m h') (unwrapMessage m)
 
     matchPrioritise :: P.Message
                     -> (a -> Priority b)
@@ -45,18 +60,20 @@ prioritiseCall h = PrioritiseCall (\s -> unCall $ h s)
       , False <- isEncoded msg = Just (getPrio $ p m, msg)
       | otherwise              = Nothing
 
+-- | Prioritise a cast handler, ignoring the server's state
 prioritiseCast_ :: forall s a . (Serializable a)
                 => (a -> Priority ())
                 -> DispatchPriority s
-prioritiseCast_ h = prioritiseCast (\_ -> h)
+prioritiseCast_ h = prioritiseCast (const h)
 
+-- | Prioritise a cast handler
 prioritiseCast :: forall s a . (Serializable a)
                => (s -> a -> Priority ())
                -> DispatchPriority s
-prioritiseCast h = PrioritiseCast (\s -> unCast $ h s)
+prioritiseCast h = PrioritiseCast (unCast . h)
   where
     unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))
-    unCast h' m = unwrapMessage m >>= return . matchPrioritise m h'
+    unCast h' m = fmap (matchPrioritise m h') (unwrapMessage m)
 
     matchPrioritise :: P.Message
                     -> (a -> Priority ())
@@ -69,18 +86,20 @@ prioritiseCast h = PrioritiseCast (\s -> unCast $ h s)
       , False <- isEncoded msg = Just (getPrio $ p m, msg)
       | otherwise              = Nothing
 
+-- | Prioritise an info handler, ignoring the server's state
 prioritiseInfo_ :: forall s a . (Serializable a)
                 => (a -> Priority ())
                 -> DispatchPriority s
-prioritiseInfo_ h = prioritiseInfo (\_ -> h)
+prioritiseInfo_ h = prioritiseInfo (const h)
 
+-- | Prioritise an info handler
 prioritiseInfo :: forall s a . (Serializable a)
                => (s -> a -> Priority ())
                -> DispatchPriority s
-prioritiseInfo h = PrioritiseInfo (\s -> unMsg $ h s)
+prioritiseInfo h = PrioritiseInfo (unMsg . h)
   where
     unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))
-    unMsg h' m = unwrapMessage m >>= return . matchPrioritise m h'
+    unMsg h' m = fmap (matchPrioritise m h') (unwrapMessage m)
 
     matchPrioritise :: P.Message
                     -> (a -> Priority ())
@@ -92,4 +111,3 @@ prioritiseInfo h = PrioritiseInfo (\s -> unMsg $ h s)
       | (Just m') <- msgIn
       , False <- isEncoded msg = Just (getPrio $ p m', msg)
       | otherwise              = Nothing
-
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index 04db47c..beeaf30 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -111,7 +111,7 @@ data RestrictedAction =
 
 -- | Log a trace message using the underlying Process's @say@
 say :: String -> RestrictedProcess s ()
-say msg = lift . P.say $ msg
+say = lift . P.say
 
 -- | Get the current process state
 getState :: RestrictedProcess s s
@@ -138,7 +138,7 @@ reply = return . Reply
 noReply :: forall s r . (Serializable r)
            => Result r
            -> RestrictedProcess s (Result r)
-noReply r = return r
+noReply = return
 
 -- | Halt process execution during a call handler, without paying any attention
 -- to the expected return type.
@@ -187,7 +187,7 @@ handleCall = handleCallIf $ Server.state (const True)
 -- that takes a handler which executes in 'RestrictedProcess'.
 --
 handleCallIf :: forall s a b . (Serializable a, Serializable b)
-             => (Condition s a)
+             => Condition s a
              -> (a -> RestrictedProcess s (Result b))
              -> Dispatcher s
 handleCallIf cond h = Server.handleCallIf cond (wrapCall h)
@@ -219,11 +219,13 @@ handleInfo :: forall s a. (Serializable a)
 -- cast and info look the same to a restricted process
 handleInfo h = Server.handleInfo (wrapHandler h)
 
+-- | Handle exit signals
 handleExit :: forall s a. (Serializable a)
            => (a -> RestrictedProcess s RestrictedAction)
            -> ExitSignalDispatcher s
-handleExit h = Server.handleExit $ \_ s a -> (wrapHandler h) s a
+handleExit h = Server.handleExit $ \_ s a -> wrapHandler h s a
 
+-- | Handle timeouts
 handleTimeout :: forall s . (Delay -> RestrictedProcess s RestrictedAction)
                          -> TimeoutHandler s
 handleTimeout h = \s d -> do
diff --git a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
index 7b9ea14..5c9b5eb 100644
--- a/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs
@@ -119,8 +119,8 @@ safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
 safeCall s m = do
   us <- getSelfPid
   (fmap fromJust (unsafeInitCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b))
-    `catchesExit` [(\pid msg -> handleMessageIf msg (weFailed pid us)
-                                                    (return . Left))]
+    `catchesExit` [\pid msg -> handleMessageIf msg (weFailed pid us)
+                                                   (return . Left)]
 
   where
 
@@ -148,11 +148,12 @@ callTimeout s m d = unsafeInitCall s m >>= waitResponse (Just d) >>= decodeResul
         decodeResult (Just (Right result)) = return $ Just result
         decodeResult (Just (Left reason))  = die reason
 
+-- | Block for @TimeInterval@ waiting for any matching @CallResponse@
 flushPendingCalls :: forall b . (NFSerializable b)
                   => TimeInterval
                   -> (b -> Process b)
                   -> Process (Maybe b)
-flushPendingCalls d proc = do
+flushPendingCalls d proc =
   receiveTimeout (asTimeout d) [
       match (\(CallResponse (m :: b) _) -> proc m)
     ]
@@ -178,7 +179,7 @@ callChan server msg = do
   unsafeSendTo server ((ChanMessage msg sp) :: Message a b)
   return rp
 
-  -- | A synchronous version of 'callChan'.
+-- | A synchronous version of 'callChan'.
 syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
          => s -> a -> Process b
 syncCallChan server msg = do

From 3c8d03beb8501eea5db29c0aded9f9b29784030d Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Wed, 22 Feb 2017 01:44:02 +0000
Subject: [PATCH 39/50] Prioritised Process Improvements

Segregate external and api handlers at the type level.
Provide a means for reading control channels and STM handlers
within a prioritised process loop.

Fixes #13
---
 .../Distributed/Process/ManagedProcess.hs     | 11 ++++-
 .../ManagedProcess/Internal/GenProcess.hs     | 21 ++++----
 .../Process/ManagedProcess/Internal/Types.hs  | 47 ++++++++++++------
 .../Process/ManagedProcess/Server.hs          | 48 ++++++++++---------
 tests/ManagedProcessCommon.hs                 | 39 +++++++++++++++
 tests/TestManagedProcess.hs                   | 35 +-------------
 tests/TestPrioritisedProcess.hs               | 46 ++++++++++++++++++
 7 files changed, 161 insertions(+), 86 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index b9c592c..6fbcbff 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -438,6 +438,7 @@ module Control.Distributed.Process.ManagedProcess
   , Priority(..)
   , DispatchPriority()
   , Dispatcher()
+  , ExternDispatcher()
   , DeferredDispatcher()
   , ShutdownHandler
   , TimeoutHandler
@@ -598,6 +599,7 @@ defaultProcess :: ProcessDefinition s
 defaultProcess = ProcessDefinition {
     apiHandlers      = []
   , infoHandlers     = []
+  , externHandlers   = []
   , exitHandlers     = []
   , timeoutHandler   = \s _ -> continue s
   , shutdownHandler  = \_ _ -> return ()
@@ -607,10 +609,15 @@ defaultProcess = ProcessDefinition {
 -- | Turns a standard 'ProcessDefinition' into a 'PrioritisedProcessDefinition',
 -- by virtue of the supplied list of 'DispatchPriority' expressions.
 --
+-- Terminates the caller with an exit signal if the supplied process definition
+-- contains any externHandlers, since these are not supported by prioritised
+-- process definitions.
+--
 prioritised :: ProcessDefinition s
             -> [DispatchPriority s]
             -> PrioritisedProcessDefinition s
-prioritised def ps = PrioritisedProcessDefinition def ps defaultRecvTimeoutPolicy
+prioritised def ps =
+  PrioritisedProcessDefinition def ps defaultRecvTimeoutPolicy
 
 -- | Sets the default 'recvTimeoutPolicy', which gives up after 10k reads.
 defaultRecvTimeoutPolicy :: RecvTimeoutPolicy
@@ -619,7 +626,7 @@ defaultRecvTimeoutPolicy = RecvCounter 10000
 -- | Creates a default 'PrioritisedProcessDefinition' from a list of
 -- 'DispatchPriority'. See 'defaultProcess' for the underlying definition.
 defaultProcessWithPriorities :: [DispatchPriority s] -> PrioritisedProcessDefinition s
-defaultProcessWithPriorities dps = prioritised defaultProcess dps
+defaultProcessWithPriorities = prioritised defaultProcess
 
 -- | A basic, stateless 'ProcessDefinition'. See 'defaultProcess' for the
 -- default field values.
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 8e2e1e6..b8a4b33 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -63,16 +63,8 @@ data CancelTimer = CancelTimer deriving (Eq, Show, Typeable)
 --
 precvLoop :: PrioritisedProcessDefinition s -> s -> Delay -> Process ExitReason
 precvLoop ppDef pState recvDelay = do
-    void $ verify $ processDef ppDef
     tref <- startTimer recvDelay
     recvQueue ppDef pState tref PriorityQ.empty
-  where
-    verify pDef = mapM_ disallowCC $ apiHandlers pDef
-
-    -- TODO: better failure messages here!
-    disallowCC (DispatchCC _ _)     = die $ ExitOther "IllegalControlChannel"
-    disallowCC (DispatchSTM _ _)    = die $ ExitOther "IllegalSTMAction"
-    disallowCC _                    = return ()
 
 recvQueue :: PrioritisedProcessDefinition s
           -> s
@@ -143,7 +135,7 @@ recvQueue p s t q =
                 -- if the internal queue is empty, we fall back to reading the
                 -- actual mailbox, however if /that/ times out, then we need
                 -- to let the timeout handler kick in again and make a decision
-                drainOrTimeout s' t' queue ps' h
+                drainOrTimeout def s' t' queue ps' h
               Just (m', q') -> do
                 act <- catchesExit (processApply def s' m')
                                    (map (\d' -> dispatchExit d' s') ex)
@@ -153,8 +145,9 @@ recvQueue p s t q =
       let pol          = unhandledMessagePolicy def
           apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
           infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
+          extMatchers  = map (dynHandleMessage pol pState) (externHandlers def)
           shutdown'    = dynHandleMessage pol pState shutdownHandler'
-          ms'          = (shutdown':apiMatchers) ++ infoMatchers
+          ms'          = (shutdown':apiMatchers) ++ infoMatchers ++ extMatchers
       in processApplyAux ms' pol pState msg
 
     processApplyAux []     p' s' m' = applyPolicy p' s' m'
@@ -164,8 +157,9 @@ recvQueue p s t q =
         Nothing  -> processApplyAux hs p' s' m'
         Just act -> return act
 
-    drainOrTimeout pState delay queue ps' h =
-      let matches = [ matchMessage return ]
+    drainOrTimeout pDef pState delay queue ps' h =
+      let p'       = unhandledMessagePolicy pDef
+          matches = ((matchMessage return):(map (matchExtern p' pState) (externHandlers pDef)))
           recv    = case delay of
                       Infinity -> fmap Just (receiveWait matches)
                       NoDelay  -> receiveTimeout 0 matches
@@ -257,7 +251,8 @@ recvLoop pDef pState recvDelay =
       handleTimeout = timeoutHandler pDef
       handleStop    = shutdownHandler pDef
       shutdown'     = matchDispatch p pState shutdownHandler'
-      matchers      = map (matchDispatch p pState) (apiHandlers pDef)
+      extMatchers   = map (matchDispatch p pState) (externHandlers pDef)
+      matchers      = extMatchers ++ (map (matchDispatch p pState) (apiHandlers pDef))
       ex'           = (trapExit:(exitHandlers pDef))
       ms' = (shutdown':matchers) ++ matchAux p pState (infoHandlers pDef)
   in do
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index a158a2f..ef16ddc 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -38,9 +38,11 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , ControlPort(..)
   , channelControlPort
   , Dispatcher(..)
+  , ExternDispatcher(..)
   , DeferredDispatcher(..)
   , ExitSignalDispatcher(..)
   , MessageMatcher(..)
+  , ExternMatcher(..)
   , DynMessageHandler(..)
   , Message(..)
   , CallResponse(..)
@@ -166,7 +168,6 @@ data Condition s m =
   | State     (s -> Bool)       -- ^ predicated on the process state only
   | Input     (m -> Bool)       -- ^ predicated on the input message only
 
-
 -- | An action (server state transition) in the @Process@ monad
 type Action s = Process (ProcessAction s)
 
@@ -254,17 +255,21 @@ data Dispatcher s =
       dispatch   :: s -> Message a b -> Process (ProcessAction s)
     , dispatchIf :: s -> Message a b -> Bool
     }
-  | forall a b . (Serializable a, Serializable b) =>
+
+-- | Provides dispatch for channels and STM actions
+data ExternDispatcher s =
+    forall a b . (Serializable a, Serializable b) =>
     DispatchCC  -- control channel dispatch
     {
-      channel  :: ReceivePort (Message a b)
-    , dispatch :: s -> Message a b -> Process (ProcessAction s)
+      channel      :: ReceivePort (Message a b)
+    , dispatchChan :: s -> Message a b -> Process (ProcessAction s)
     }
-  | forall a .
+  | forall a . (Serializable a) =>
     DispatchSTM -- arbitrary STM actions
     {
       stmAction   :: STM a
-    , stmDispatch :: s -> a -> Process (ProcessAction s)
+    , dispatchStm :: s -> a -> Process (ProcessAction s)
+    , matchStm    :: Match P.Message
     }
 
 -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.
@@ -291,10 +296,19 @@ class MessageMatcher d where
   matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)
 
 instance MessageMatcher Dispatcher where
-  matchDispatch _ s (Dispatch    d)        = match (d s)
-  matchDispatch _ s (DispatchIf  d cond)   = matchIf (cond s) (d s)
-  matchDispatch _ s (DispatchCC  c d)      = matchChan c (d s)
-  matchDispatch _ s (DispatchSTM c d)      = matchSTM c (d s)
+  matchDispatch _ s (Dispatch    d)      = match   (d s)
+  matchDispatch _ s (DispatchIf  d cond) = matchIf (cond s) (d s)
+
+instance MessageMatcher ExternDispatcher where
+  matchDispatch _ s (DispatchCC  c d)   = matchChan c (d s)
+  matchDispatch _ s (DispatchSTM c d _) = matchSTM  c (d s)
+
+class ExternMatcher d where
+  matchExtern :: UnhandledMessagePolicy -> s -> d s -> Match P.Message
+
+instance ExternMatcher ExternDispatcher where
+  matchExtern _ _ (DispatchCC  c _)   = matchChan c (return . unsafeWrapMessage)
+  matchExtern _ _ (DispatchSTM _ _ m) = m
 
 -- | Maps handlers to a dynamic action that can take place outside of a
 -- expect/recieve block.
@@ -308,8 +322,10 @@ class DynMessageHandler d where
 instance DynMessageHandler Dispatcher where
   dynHandleMessage _ s (Dispatch       d)   msg = handleMessage   msg (d s)
   dynHandleMessage _ s (DispatchIf     d c) msg = handleMessageIf msg (c s) (d s)
-  dynHandleMessage _ _ (DispatchCC     _ _) _   = error "ThisCanNeverHappen"
-  dynHandleMessage _ _ (DispatchSTM    _ _) _   = error "ThisCanNeverHappen"
+
+instance DynMessageHandler ExternDispatcher where
+  dynHandleMessage _ s (DispatchCC  _ d)   msg = handleMessage msg (d s)
+  dynHandleMessage _ s (DispatchSTM _ d _) msg = handleMessage msg (d s)
 
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
@@ -368,9 +384,10 @@ data UnhandledMessagePolicy =
 -- | Stores the functions that determine runtime behaviour in response to
 -- incoming messages and a policy for responding to unhandled messages.
 data ProcessDefinition s = ProcessDefinition {
-    apiHandlers  :: [Dispatcher s]     -- ^ functions that handle call/cast messages
-  , infoHandlers :: [DeferredDispatcher s] -- ^ functions that handle non call/cast messages
-  , exitHandlers :: [ExitSignalDispatcher s] -- ^ functions that handle exit signals
+    apiHandlers    :: [Dispatcher s]       -- ^ functions that handle call/cast messages
+  , infoHandlers   :: [DeferredDispatcher s] -- ^ functions that handle non call/cast messages
+  , externHandlers :: [ExternDispatcher s] -- ^ functions that handle control channel and STM inputs
+  , exitHandlers   :: [ExitSignalDispatcher s] -- ^ functions that handle exit signals
   , timeoutHandler :: TimeoutHandler s   -- ^ a function that handles timeouts
   , shutdownHandler :: ShutdownHandler s -- ^ a function that is run just before the process exits
   , unhandledMessagePolicy :: UnhandledMessagePolicy -- ^ how to deal with unhandled messages
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 74296a9..3e22e40 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -399,18 +399,20 @@ handleCastIf cond h
 --
 -- NB: this function cannot be used with a prioristised process definition.
 --
-handleExternal :: forall s a .
-       STM a
-    -> ActionHandler s a
-    -> Dispatcher s
-handleExternal = DispatchSTM
+handleExternal :: forall s a . (Serializable a)
+               => STM a
+               -> ActionHandler s a
+               -> ExternDispatcher s
+handleExternal a h =
+  DispatchSTM a h (matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m))
 
 -- | Version of @handleExternal@ that ignores state.
-handleExternal_ :: forall s a .
-       STM a
-    -> StatelessHandler s a
-    -> Dispatcher s
-handleExternal_ a h = DispatchSTM a $ flip h
+handleExternal_ :: forall s a . (Serializable a)
+                => STM a
+                -> StatelessHandler s a
+                -> ExternDispatcher s
+handleExternal_ a h =
+  DispatchSTM a (flip h) (matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m))
 
 -- | Handle @call@ style API interactions using arbitrary /STM/ actions.
 --
@@ -418,15 +420,17 @@ handleExternal_ a h = DispatchSTM a $ flip h
 -- yields a value, and a second expression that is used to send a reply back
 -- to the /caller/. The corrolary client API is /callSTM/.
 --
-handleCallExternal :: forall s r w .
-                      STM r
+handleCallExternal :: forall s r w . (Serializable r)
+                   => STM r
                    -> (w -> STM ())
                    -> CallHandler s r w
-                   -> Dispatcher s
+                   -> ExternDispatcher s
 handleCallExternal reader writer handler
-  = DispatchSTM { stmAction   = reader
-                , stmDispatch = doStmReply handler
-                }
+  = DispatchSTM
+    { stmAction   = reader
+    , dispatchStm = doStmReply handler
+    , matchStm    = matchSTM reader (\(m :: r) -> return $ unsafeWrapMessage m)
+    }
   where
     doStmReply d s m = d s m >>= doXfmReply writer
 
@@ -443,10 +447,10 @@ handleControlChan :: forall s a . (Serializable a)
     => ControlChannel a -- ^ the receiving end of the control channel
     -> ActionHandler s a
        -- ^ an action yielding function over the process state and input message
-    -> Dispatcher s
+    -> ExternDispatcher s
 handleControlChan chan h
-  = DispatchCC { channel  = snd $ unControl chan
-               , dispatch = \s ((CastMessage p) :: Message a ()) -> h s p
+  = DispatchCC { channel      = snd $ unControl chan
+               , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h s p
                }
 
 -- | Version of 'handleControlChan' that ignores the server state.
@@ -454,10 +458,10 @@ handleControlChan chan h
 handleControlChan_ :: forall s a. (Serializable a)
            => ControlChannel a
            -> StatelessHandler s a
-           -> Dispatcher s
+           -> ExternDispatcher s
 handleControlChan_ chan h
-  = DispatchCC { channel    = snd $ unControl chan
-               , dispatch   = \s ((CastMessage p) :: Message a ()) -> h p s
+  = DispatchCC { channel      = snd $ unControl chan
+               , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h p s
                }
 
 -- | Version of 'handleCast' that ignores the server state.
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 3d92dd3..6f21baa 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -1,9 +1,16 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE RecordWildCards     #-}
 
 module ManagedProcessCommon where
 
 import Control.Concurrent.MVar (MVar)
+import Control.Concurrent.STM.TQueue
+ ( newTQueueIO
+ , readTQueue
+ , writeTQueue
+ , TQueue
+ )
 import Control.Distributed.Process hiding (call, send)
 import Control.Distributed.Process.Extras hiding (monitor)
 import qualified Control.Distributed.Process as P
@@ -67,6 +74,38 @@ standardTestServer policy =
 wrap :: (Process (ProcessId, MVar ExitReason)) -> Launcher a
 wrap it = \_ -> do it
 
+data StmServer = StmServer { serverPid  :: ProcessId
+                           , writerChan :: TQueue String
+                           , readerChan :: TQueue String
+                           }
+
+instance Resolvable StmServer where
+  resolve = return . Just . serverPid
+
+echoStm :: StmServer -> String -> Process (Either ExitReason String)
+echoStm StmServer{..} = callSTM serverPid
+                                (writeTQueue writerChan)
+                                (readTQueue  readerChan)
+
+launchEchoServer :: CallHandler () String String -> Process StmServer
+launchEchoServer handler = do
+  (inQ, replyQ) <- liftIO $ do
+    cIn <- newTQueueIO
+    cOut <- newTQueueIO
+    return (cIn, cOut)
+
+  let procDef = statelessProcess {
+                  externHandlers = [
+                    handleCallExternal
+                      (readTQueue inQ)
+                      (writeTQueue replyQ)
+                      handler
+                  ]
+                }
+
+  pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
+  return $ StmServer pid inQ replyQ
+
 -- common test cases
 
 testBasicCall :: Launcher () -> TestResult (Maybe String) -> Process ()
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index 306a13d..880d5dc 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -8,7 +8,6 @@ import Control.Concurrent.STM.TQueue
  ( newTQueueIO
  , readTQueue
  , writeTQueue
- , TQueue
  )
 import Control.Concurrent.MVar
 import Control.Exception (SomeException)
@@ -104,7 +103,7 @@ testExternalService result = do
   inChan <- liftIO newTQueueIO
   replyQ <- liftIO newTQueueIO
   let procDef = statelessProcess {
-                    apiHandlers = [
+                    externHandlers = [
                       handleExternal
                         (readTQueue inChan)
                         (\s (m :: String) -> do
@@ -123,38 +122,6 @@ testExternalService result = do
   stash result (echoTxt == txt)
   kill pid "done"
 
-data StmServer = StmServer { serverPid  :: ProcessId
-                           , writerChan :: TQueue String
-                           , readerChan :: TQueue String
-                           }
-
-instance Resolvable StmServer where
-  resolve = return . Just . serverPid
-
-echoStm :: StmServer -> String -> Process (Either ExitReason String)
-echoStm StmServer{..} = callSTM serverPid
-                                (writeTQueue writerChan)
-                                (readTQueue  readerChan)
-
-launchEchoServer :: CallHandler () String String -> Process StmServer
-launchEchoServer handler = do
-  (inQ, replyQ) <- liftIO $ do
-    cIn <- newTQueueIO
-    cOut <- newTQueueIO
-    return (cIn, cOut)
-
-  let procDef = statelessProcess {
-                  apiHandlers = [
-                    handleCallExternal
-                      (readTQueue inQ)
-                      (writeTQueue replyQ)
-                      handler
-                  ]
-                }
-
-  pid <- spawnLocal $ serve () (statelessInit Infinity) procDef
-  return $ StmServer pid inQ replyQ
-
 testExternalCall :: TestResult Bool -> Process ()
 testExternalCall result = do
   let txt = "hello stm-call foo"
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 0196bc7..e025848 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -5,6 +5,11 @@
 module Main where
 
 import Control.Concurrent.MVar
+import Control.Concurrent.STM.TQueue
+ ( newTQueueIO
+ , readTQueue
+ , writeTQueue
+ )
 import Control.Exception (SomeException)
 import Control.DeepSeq (NFData)
 import Control.Distributed.Process hiding (call, send, catch)
@@ -137,6 +142,41 @@ mkOverflowHandlingServer modIt =
             ]
           } :: ProcessDefinition Int
 
+launchStmServer :: CallHandler () String String -> Process StmServer
+launchStmServer handler = do
+  (inQ, replyQ) <- liftIO $ do
+    cIn <- newTQueueIO
+    cOut <- newTQueueIO
+    return (cIn, cOut)
+
+  let procDef = statelessProcess {
+                  externHandlers = [
+                    handleCallExternal
+                      (readTQueue inQ)
+                      (writeTQueue replyQ)
+                      handler
+                  ]
+                , apiHandlers = [
+                    action (\() -> stop_ ExitNormal)
+                  ]
+                }
+
+  let p = procDef `prioritised` ([
+               prioritiseCast_ (\() -> setPriority 99 :: Priority ())
+             , prioritiseCast_ (\(_ :: String) -> setPriority 100)
+             ] :: [DispatchPriority ()]
+          ) :: PrioritisedProcessDefinition ()
+
+  pid <- spawnLocal $ pserve () (statelessInit Infinity) p
+  return $ StmServer pid inQ replyQ
+
+testExternalCall :: TestResult Bool -> Process ()
+testExternalCall result = do
+  let txt = "hello stm-call foo"
+  srv <- launchStmServer (\st (msg :: String) -> reply msg st)
+  echoStm srv txt >>= stash result . (== Right txt)
+  killProc srv "done"
+
 testTimedOverflowHandling :: TestResult Bool -> Process ()
 testTimedOverflowHandling result = do
   pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvTimer $ within 3 Seconds })
@@ -267,6 +307,12 @@ tests transport = do
             (delayedAssertion "expected the server loop to stop reading the mailbox"
              localNode True testTimedOverflowHandling)
           ]
+          , testGroup "Advanced Server Interactions" [
+              testCase "using callSTM to manage non-CH interactions"
+              (delayedAssertion
+               "expected the server to reply back via the TQueue"
+               localNode True testExternalCall)
+            ]
       ]
 
 main :: IO ()

From 0cc32aed20cd318963d8bed3f3fefb73b3112e2b Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Wed, 22 Feb 2017 15:27:51 +0000
Subject: [PATCH 40/50] Read external input vectors in the prioritised mailbox
 drain loop

Fixes #15
---
 .../ManagedProcess/Internal/GenProcess.hs     | 64 +++++++++++++------
 .../Process/ManagedProcess/Internal/Types.hs  | 20 ++++--
 .../Process/ManagedProcess/Server.hs          | 23 +++++--
 tests/TestPrioritisedProcess.hs               | 63 ++++++++++++++++--
 4 files changed, 132 insertions(+), 38 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index b8a4b33..376b41d 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -88,11 +88,12 @@ recvQueue p s t q =
       | otherwise {- compiler foo -} = die "IllegalState"
 
     recvQueueAux ppDef prioritizers pState delay queue =
-      let ex = trapExit:(exitHandlers $ processDef ppDef)
-          eh = map (\d' -> (dispatchExit d') pState) ex
-          mx = recvTimeout ppDef
+      let pDef = processDef ppDef
+          ex   = trapExit:(exitHandlers $ pDef)
+          eh   = map (\d' -> (dispatchExit d') pState) ex
+          mx   = recvTimeout ppDef
       in (do t' <- startTimer delay
-             mq <- drainMessageQueue mx pState prioritizers queue
+             mq <- drainMessageQueue mx pDef pState prioritizers queue
              recvQueue ppDef pState t' mq)
          `catchExit`
          (\pid (reason :: ExitReason) -> do
@@ -157,9 +158,17 @@ recvQueue p s t q =
         Nothing  -> processApplyAux hs p' s' m'
         Just act -> return act
 
+    -- This is the only place where it is sanely possible to apply external
+    -- handlers (i.e. control channel and stm handlers) without overcomplicating
+    -- the loop too much. What we sacrifice is the ability to read from these
+    -- channels whilst draining our mailbox, which means that conversely with
+    -- an ordinary server loop, external handlers could well be de-prioritised
+    -- here! There are, however, no guarantees about this, therefore it is
+    -- probably best to simply document this infelicity and leave it to the
+    -- programmer to decide if they wish to punt on such matters at runtime.
     drainOrTimeout pDef pState delay queue ps' h =
       let p'       = unhandledMessagePolicy pDef
-          matches = ((matchMessage return):(map (matchExtern p' pState) (externHandlers pDef)))
+          matches = ((matchMessage return):map (matchExtern p' pState) (externHandlers pDef))
           recv    = case delay of
                       Infinity -> fmap Just (receiveWait matches)
                       NoDelay  -> receiveTimeout 0 matches
@@ -175,38 +184,57 @@ recvQueue p s t q =
             return (ProcessContinue pState, delay, queue')
 
 drainMessageQueue :: RecvTimeoutPolicy
+                  -> ProcessDefinition s
                   -> s
                   -> [DispatchPriority s]
                   -> Queue
                   -> Process Queue
-drainMessageQueue limit pState priorities' queue = do
+drainMessageQueue limit pDef pState priorities' queue = do
     timerAcc <- case limit of
                   RecvTimer   tm  -> setupTimer tm
                   RecvCounter cnt -> return $ Right cnt
-    drainMessageQueueAux timerAcc pState priorities' queue
+    drainMessageQueueAux pDef timerAcc pState priorities' queue
 
   where
 
-    drainMessageQueueAux acc st ps q = do
-      (acc', m) <- drainIt acc
+    drainMessageQueueAux pd acc st ps q = do
+      (acc', m) <- drainIt st pd acc
       -- say $ "drained " ++ show m
       case m of
         Nothing                 -> return q
         Just (Left CancelTimer) -> return q
         Just (Right m')         -> do
           queue' <- enqueueMessage st ps m' q
-          drainMessageQueueAux acc' st ps queue'
+          drainMessageQueueAux pd acc' st ps queue'
 
-    drainIt :: Either (STM CancelTimer) Int
+    drainIt :: s
+            -> ProcessDefinition s
+            -> Either (STM CancelTimer) Int
             -> Process (Either (STM CancelTimer) Int,
                         Maybe (Either CancelTimer P.Message))
-    drainIt e@(Right 0)  = return (e, Just (Left CancelTimer))
-    drainIt (Right cnt)  = fmap (Right $ cnt - 1, )
-                                (receiveTimeout 0 [ matchAny (return . Right) ])
-    drainIt a@(Left stm) = fmap (a, )
-                                (receiveTimeout 0 [ matchSTM stm (return . Left)
-                                                  , matchAny     (return . Right)
-                                                  ])
+    drainIt _  _  e@(Right 0)  = return (e, Just (Left CancelTimer))
+    drainIt s' d' (Right cnt)  =
+      fmap (Right (cnt - 1), )
+           (receiveTimeout 0 (matchAny (return . Right): mkMatchers s' d'))
+    drainIt s' d' a@(Left stm) =
+      fmap (a, )
+           (receiveTimeout 0 ([ matchSTM stm (return . Left)
+                              , matchAny     (return . Right)
+                              ]  ++ mkMatchers s' d'))
+
+    mkMatchers :: s
+               -> ProcessDefinition s
+               -> [Match (Either CancelTimer P.Message)]
+    mkMatchers st df =
+      map (matchMapExtern (unhandledMessagePolicy df) st toRight)
+          (externHandlers df)
+
+    toRight :: P.Message -> Either CancelTimer P.Message
+    toRight = Right
+
+    -- pass the s' and the p' here and do our thing with matchMapExtern
+    -- matches = ((matchMessage return):(map (matchExtern p' pState) (externHandlers pDef)))
+    -- matchMapExtern
 
     setupTimer intv = do
       chan <- liftIO newTChanIO
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index ef16ddc..e015007 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LiberalTypeSynonyms        #-}
+{-# LANGUAGE Rank2Types                 #-}
 
 -- | Types used throughout the ManagedProcess framework
 module Control.Distributed.Process.ManagedProcess.Internal.Types
@@ -270,6 +271,7 @@ data ExternDispatcher s =
       stmAction   :: STM a
     , dispatchStm :: s -> a -> Process (ProcessAction s)
     , matchStm    :: Match P.Message
+    , matchAnyStm :: forall m . (P.Message -> m) -> Match m
     }
 
 -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.
@@ -300,15 +302,21 @@ instance MessageMatcher Dispatcher where
   matchDispatch _ s (DispatchIf  d cond) = matchIf (cond s) (d s)
 
 instance MessageMatcher ExternDispatcher where
-  matchDispatch _ s (DispatchCC  c d)   = matchChan c (d s)
-  matchDispatch _ s (DispatchSTM c d _) = matchSTM  c (d s)
+  matchDispatch _ s (DispatchCC  c d)     = matchChan c (d s)
+  matchDispatch _ s (DispatchSTM c d _ _) = matchSTM  c (d s)
 
 class ExternMatcher d where
   matchExtern :: UnhandledMessagePolicy -> s -> d s -> Match P.Message
 
+  matchMapExtern :: forall m s . UnhandledMessagePolicy
+                 -> s -> (P.Message -> m) -> d s -> Match m
+
 instance ExternMatcher ExternDispatcher where
-  matchExtern _ _ (DispatchCC  c _)   = matchChan c (return . unsafeWrapMessage)
-  matchExtern _ _ (DispatchSTM _ _ m) = m
+  matchExtern _ _ (DispatchCC  c _)     = matchChan c (return . unsafeWrapMessage)
+  matchExtern _ _ (DispatchSTM _ _ m _) = m
+
+  matchMapExtern _ _ f (DispatchCC c _)      = matchChan c (return . f . unsafeWrapMessage)
+  matchMapExtern _ _ f (DispatchSTM _ _ _ p) = p f
 
 -- | Maps handlers to a dynamic action that can take place outside of a
 -- expect/recieve block.
@@ -324,8 +332,8 @@ instance DynMessageHandler Dispatcher where
   dynHandleMessage _ s (DispatchIf     d c) msg = handleMessageIf msg (c s) (d s)
 
 instance DynMessageHandler ExternDispatcher where
-  dynHandleMessage _ s (DispatchCC  _ d)   msg = handleMessage msg (d s)
-  dynHandleMessage _ s (DispatchSTM _ d _) msg = handleMessage msg (d s)
+  dynHandleMessage _ s (DispatchCC  _ d)     msg = handleMessage msg (d s)
+  dynHandleMessage _ s (DispatchSTM _ d _ _) msg = handleMessage msg (d s)
 
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 3e22e40..91de962 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -404,15 +404,21 @@ handleExternal :: forall s a . (Serializable a)
                -> ActionHandler s a
                -> ExternDispatcher s
 handleExternal a h =
-  DispatchSTM a h (matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m))
+  let matchMsg'   = matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m)
+      matchAny' f = matchSTM a (\(m :: r) -> return $ f (unsafeWrapMessage m)) in
+  DispatchSTM
+    { stmAction   = a
+    , dispatchStm = h
+    , matchStm    = matchMsg'
+    , matchAnyStm = matchAny'
+    }
 
 -- | Version of @handleExternal@ that ignores state.
 handleExternal_ :: forall s a . (Serializable a)
                 => STM a
                 -> StatelessHandler s a
                 -> ExternDispatcher s
-handleExternal_ a h =
-  DispatchSTM a (flip h) (matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m))
+handleExternal_ a h = handleExternal a (flip h)
 
 -- | Handle @call@ style API interactions using arbitrary /STM/ actions.
 --
@@ -425,11 +431,14 @@ handleCallExternal :: forall s r w . (Serializable r)
                    -> (w -> STM ())
                    -> CallHandler s r w
                    -> ExternDispatcher s
-handleCallExternal reader writer handler
-  = DispatchSTM
+handleCallExternal reader writer handler =
+  let matchMsg'   = matchSTM reader (\(m :: r) -> return $ unsafeWrapMessage m)
+      matchAny' f = matchSTM reader (\(m :: r) -> return $ f $ unsafeWrapMessage m) in
+  DispatchSTM
     { stmAction   = reader
     , dispatchStm = doStmReply handler
-    , matchStm    = matchSTM reader (\(m :: r) -> return $ unsafeWrapMessage m)
+    , matchStm    = matchMsg'
+    , matchAnyStm = matchAny'
     }
   where
     doStmReply d s m = d s m >>= doXfmReply writer
@@ -479,7 +488,7 @@ handleCastIf_ :: forall s a . (Serializable a)
         -- ^ a function from the input message to a /stateless action/, cf 'continue_'
     -> Dispatcher s
 handleCastIf_ cond h
-  = DispatchIf { dispatch   = \s ((CastMessage p) :: Message a ()) -> h p s
+  = DispatchIf { dispatch   = \s ((CastMessage p) :: Message a ()) -> h p $ s
                , dispatchIf = checkCast cond
                }
 
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index e025848..aa9a9cc 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -12,7 +12,7 @@ import Control.Concurrent.STM.TQueue
  )
 import Control.Exception (SomeException)
 import Control.DeepSeq (NFData)
-import Control.Distributed.Process hiding (call, send, catch)
+import Control.Distributed.Process hiding (call, send, catch, sendChan)
 import Control.Distributed.Process.Node
 import Control.Distributed.Process.Extras hiding (__remoteTable)
 import Control.Distributed.Process.Async
@@ -170,6 +170,52 @@ launchStmServer handler = do
   pid <- spawnLocal $ pserve () (statelessInit Infinity) p
   return $ StmServer pid inQ replyQ
 
+launchStmOverloadServer :: Process (ProcessId, ControlPort String)
+launchStmOverloadServer = do
+  cc <- newControlChan :: Process (ControlChannel String)
+  let cp = channelControlPort cc
+
+  let procDef = statelessProcess {
+                  externHandlers = [
+                    handleControlChan_ cc (\(_ :: String) -> continue_)
+                  ]
+                , apiHandlers = [
+                    handleCast (\s sp -> sendChan sp () >> continue s)
+                  ]
+                }
+
+  let p = procDef `prioritised` ([
+               prioritiseCast_ (\() -> setPriority 99 :: Priority ())
+             ] :: [DispatchPriority ()]
+          ) :: PrioritisedProcessDefinition ()
+
+  pid <- spawnLocal $ pserve () (statelessInit Infinity) p
+  return (pid, cp)
+
+testExternalTimedOverflowHandling :: TestResult Bool -> Process ()
+testExternalTimedOverflowHandling result = do
+  (pid, cp) <- launchStmOverloadServer -- default 10k mailbox drain limit
+  wrk <- spawnLocal $ mapM_ (sendControlMessage cp . show) ([1..500000] :: [Int])
+
+  sleep $ milliSeconds 250 -- give the worker time to start spamming the server...
+
+  (sp, rp) <- newChan
+  cast pid sp -- tell the server we're expecting a reply
+
+  -- it might take "a while" for us to get through the first 10k messages
+  -- from our chatty friend wrk, before we finally get our control message seen
+  -- by the reader/listener loop, and in fact timing wise we don't even know when
+  -- our message will arrive, since we're racing with wrk to communicate with
+  -- the server. It's important therefore to give sufficient time for the right
+  -- conditions to occur so that our message is finally received and processed,
+  -- yet we don't want to lock up the build for 10-20 mins either. This value
+  -- of 30 seconds seems like a reasonable compromise.
+  answer <- receiveChanTimeout (asTimeout $ seconds 30) rp
+
+  stash result $ answer == Just ()
+  kill wrk "done"
+  kill pid "done"
+
 testExternalCall :: TestResult Bool -> Process ()
 testExternalCall result = do
   let txt = "hello stm-call foo"
@@ -307,12 +353,15 @@ tests transport = do
             (delayedAssertion "expected the server loop to stop reading the mailbox"
              localNode True testTimedOverflowHandling)
           ]
-          , testGroup "Advanced Server Interactions" [
-              testCase "using callSTM to manage non-CH interactions"
-              (delayedAssertion
-               "expected the server to reply back via the TQueue"
-               localNode True testExternalCall)
-            ]
+       , testGroup "Advanced Server Interactions" [
+            testCase "using callSTM to manage non-CH interactions"
+            (delayedAssertion
+             "expected the server to reply back via the TQueue"
+             localNode True testExternalCall)
+          , testCase "Timeout-Based Overload Management with Control Channels"
+            (delayedAssertion "expected the server loop to reply"
+             localNode True testExternalTimedOverflowHandling)
+         ]
       ]
 
 main :: IO ()

From 6b04a2f49da4cb207bcb055f3c489b2f8a1a118c Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Wed, 22 Feb 2017 17:50:26 +0000
Subject: [PATCH 41/50] documentation/notes [ci skip]

---
 .../ManagedProcess/Internal/GenProcess.hs     | 123 ++++++++++++++----
 1 file changed, 96 insertions(+), 27 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 376b41d..1143cc2 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -66,6 +66,72 @@ precvLoop ppDef pState recvDelay = do
     tref <- startTimer recvDelay
     recvQueue ppDef pState tref PriorityQ.empty
 
+{- note [flow control]
+
+This "receive loop" is a bit daunting, so we'll walk through it bit by bit.
+
+TL;DR we have a recursive structure of
+
+recvQueue >> processNext >>= nextAction
+      >>= recvQueueAux | return
+          recvQueueAux -> drainMessageQueue >>= recvQueue
+
+First recvQueue attempts to processNext, catching exits and returning
+ProcessStop ExitReason if they arrive. The result of processNext will be
+a triple of (ProcessAction state, delay, mailQueue).
+
+processNext checks to see if we've timed out, and if we have does the
+corresponding work (calling handlers, checks if we're stopping or continuing, etc.)
+If we're still running, it tries to dequeue the next message from the Internal
+mailQueue (a priority queue of messages) and if this succeeds, evaluates a
+handler and yields the resulting ProcessAction.
+
+If the internal mailQueue is empty, processNext evalutes drainOrTimeout, which
+performs a real 'receiveTimeout' and yields the next action (possibly enqueueing
+any received <<single>> message into mailQueue beforehand).
+
+When nextAction evaluates recvQueueAux, this uses drainMessageQueue to loop over
+the process mailbox (and any external matches, such as matchChan or matchSTM
+actions), enqueueing messages into mailQueue until no further mail is available,
+at which point it gives back the mailQueue.
+
+To prevent a DOS vector - and quite a likely accidental one at that - we do not
+sit draining the mailbox indefinitely, since a continuous stream of messages would
+leave us unable to process any inputs and we'd eventually run out of memory.
+Instead, the PrioritisedProcessDefinition holds a RecvTimeoutPolicy which can
+hold either a max-messages-processed limit or a timeout value. Using whichever
+policy is provided, drainMessageQueue will stop attempting to receive new mail
+either once the message count limit is exceeded or the timer expires, at which
+point we go back to processNext.
+
+A note on timeout handling (see the section, Simulated Receive Timeouts later):
+we utilise a combination of the Timer module (from -extras) and STM channels to
+handle timeouts in the mailbox draining loops. This means that for every time we
+go into the mailbox draining loop, we launch a peer process. The overheads are
+actually pretty low, but given the variety of work that we do here to handle
+prioritisation, the runtime profile of a process using this loop will differ
+/significantly/ from an ordinary recvLoop process.
+
+TODO: We have two timers for two different purposes - one that the handlers can
+specify as the [max time we should wait for mail before running a timeout
+handler], and another that ensures we don't get stuck draining messages forever.
+We should leverage just the one timer for this purpose, when the
+RecvTimeoutPolicy specifies one, and save ourselves two timers...
+
+TODO: ALSO! The timeout handling here is broken, because we don't listen for
+the server's timeout-spec channel in the drain mailbox implementation, which
+means we can arrive in processNext /long after the timeout should've expired/
+and then notice we'd hit it, and have to continue out of step...
+
+TODO: see nextAction for details on the two things above.
+
+NB: I THINK we can implement both timers using a single control plane, if we
+simply hold a broadcastTChan for writing and the readers dupTChan when they
+want to receive notifications. The channel can be polled easily during mailbox
+draining and written to safely by multiple writers that have dupTChan'd it
+
+-}
+
 recvQueue :: PrioritisedProcessDefinition s
           -> s
           -> TimeoutSpec
@@ -79,7 +145,22 @@ recvQueue p s t q =
                                    return (ProcessStop r, Infinity, q))
         nextAction ac d q'
   where
+{-
+REMOVED COMMENT FROM ABOVE ESSAY UNTIL IMPLEMENTED PROPERLY
+
+Also note that recvQueueAux will immediately pass control to processNext if the
+internal queue is non-empty, such that we favour processing message we've
+already received over reading our mailbox until we've emptied our internal
+queue, at which point our preference switches over to draining the real mailbox
+(and other input vectors) until we time out or hit the read size limit.
+
+-}
+
     nextAction ac d q'
+      -- TODO: if PQ.isEmpty q' == False, should we not continue working on
+      -- the mail we've already got?
+      -- that would mean evaluating something like
+      -- recvQueue ppDef pState (delay, Nothing) queue
       | ProcessContinue  s'    <- ac = recvQueueAux p (priorities p) s' d  q'
       | ProcessTimeout   t' s' <- ac = recvQueueAux p (priorities p) s' t' q'
       | ProcessHibernate d' s' <- ac = block d' >> recvQueueAux p (priorities p) s' d q'
@@ -88,21 +169,21 @@ recvQueue p s t q =
       | otherwise {- compiler foo -} = die "IllegalState"
 
     recvQueueAux ppDef prioritizers pState delay queue =
-      let pDef = processDef ppDef
-          ex   = trapExit:(exitHandlers $ pDef)
-          eh   = map (\d' -> (dispatchExit d') pState) ex
-          mx   = recvTimeout ppDef
-      in (do t' <- startTimer delay
-             mq <- drainMessageQueue mx pDef pState prioritizers queue
-             recvQueue ppDef pState t' mq)
-         `catchExit`
-         (\pid (reason :: ExitReason) -> do
-             let pd = processDef ppDef
-             let ps = pState
-             let pq = queue
-             let em = unsafeWrapMessage reason
-             (a, d, q') <- findExitHandlerOrStop pd ps pq eh pid em
-             nextAction a d q')
+        let pDef = processDef ppDef
+            ex   = trapExit:(exitHandlers $ pDef)
+            eh   = map (\d' -> (dispatchExit d') pState) ex
+            mx   = recvTimeout ppDef
+        in (do t' <- startTimer delay
+               mq <- drainMessageQueue mx pDef pState prioritizers queue
+               recvQueue ppDef pState t' mq)
+           `catchExit`
+           (\pid (reason :: ExitReason) -> do
+               let pd = processDef ppDef
+               let ps = pState
+               let pq = queue
+               let em = unsafeWrapMessage reason
+               (a, d, q') <- findExitHandlerOrStop pd ps pq eh pid em
+               nextAction a d q')
 
     findExitHandlerOrStop :: ProcessDefinition s
                           -> s
@@ -158,14 +239,6 @@ recvQueue p s t q =
         Nothing  -> processApplyAux hs p' s' m'
         Just act -> return act
 
-    -- This is the only place where it is sanely possible to apply external
-    -- handlers (i.e. control channel and stm handlers) without overcomplicating
-    -- the loop too much. What we sacrifice is the ability to read from these
-    -- channels whilst draining our mailbox, which means that conversely with
-    -- an ordinary server loop, external handlers could well be de-prioritised
-    -- here! There are, however, no guarantees about this, therefore it is
-    -- probably best to simply document this infelicity and leave it to the
-    -- programmer to decide if they wish to punt on such matters at runtime.
     drainOrTimeout pDef pState delay queue ps' h =
       let p'       = unhandledMessagePolicy pDef
           matches = ((matchMessage return):map (matchExtern p' pState) (externHandlers pDef))
@@ -232,10 +305,6 @@ drainMessageQueue limit pDef pState priorities' queue = do
     toRight :: P.Message -> Either CancelTimer P.Message
     toRight = Right
 
-    -- pass the s' and the p' here and do our thing with matchMapExtern
-    -- matches = ((matchMessage return):(map (matchExtern p' pState) (externHandlers pDef)))
-    -- matchMapExtern
-
     setupTimer intv = do
       chan <- liftIO newTChanIO
       void $ runAfter intv $ liftIO $ atomically $ writeTChan chan CancelTimer

From 272ecde16657b178f2db6cd52d8a08ef916900c4 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Sat, 25 Feb 2017 04:00:24 +0000
Subject: [PATCH 42/50] Re-implement Prioritised Managed Processes

Complete rewrite of the precv loop, with more robust error handling and better management of state transitions in the face of async exceptions.
This is an API + Contract breaking change.
---
 distributed-process-client-server.cabal       |  12 +-
 .../Distributed/Process/ManagedProcess.hs     | 357 +++++---
 .../Process/ManagedProcess/Client.hs          |   3 +
 .../ManagedProcess/Internal/GenProcess.hs     | 816 +++++++++++-------
 .../Process/ManagedProcess/Internal/Types.hs  |  34 +-
 .../Process/ManagedProcess/Server.hs          |   4 +
 .../Process/ManagedProcess/Timer.hs           | 144 ++++
 tests/Counter.hs                              |   5 +-
 tests/ManagedProcessCommon.hs                 |  12 +-
 tests/TestPrioritisedProcess.hs               |   6 +-
 10 files changed, 920 insertions(+), 473 deletions(-)
 create mode 100644 src/Control/Distributed/Process/ManagedProcess/Timer.hs

diff --git a/distributed-process-client-server.cabal b/distributed-process-client-server.cabal
index b82c3b4..ddbba28 100644
--- a/distributed-process-client-server.cabal
+++ b/distributed-process-client-server.cabal
@@ -26,7 +26,7 @@ source-repository head
 
 library
   build-depends:
-                   base >= 4.4 && < 5,
+                   base >= 4.8.2.0 && < 5,
                    distributed-process >= 0.6.6 && < 0.7,
                    distributed-process-extras >= 0.3.1 && < 0.4,
                    distributed-process-async >= 0.2.4 && < 0.3,
@@ -55,7 +55,8 @@ library
                    Control.Distributed.Process.ManagedProcess.UnsafeClient,
                    Control.Distributed.Process.ManagedProcess.Server,
                    Control.Distributed.Process.ManagedProcess.Server.Priority,
-                   Control.Distributed.Process.ManagedProcess.Server.Restricted
+                   Control.Distributed.Process.ManagedProcess.Server.Restricted,
+                   Control.Distributed.Process.ManagedProcess.Timer
   other-modules:
                    Control.Distributed.Process.ManagedProcess.Internal.Types,
                    Control.Distributed.Process.ManagedProcess.Internal.GenProcess
@@ -87,6 +88,11 @@ test-suite ManagedProcessTests
                    rematch >= 0.2.0.0,
                    ghc-prim,
                    exceptions >= 0.5
+  other-modules:   Counter,
+                   ManagedProcessCommon,
+                   MathsDemo,
+                   SafeCounter,
+                   TestUtils
   hs-source-dirs:
                    tests
   ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
@@ -120,6 +126,8 @@ test-suite PrioritisedProcessTests
                    rematch >= 0.2.0.0,
                    ghc-prim,
                    exceptions >= 0.5
+  other-modules:   ManagedProcessCommon,
+                   TestUtils
   hs-source-dirs:
                    tests
   ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 6fbcbff..c0808b9 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -20,7 +20,7 @@
 -- In particular, a /managed process/ will interoperate cleanly with the
 -- supervisor API in distributed-process-supervision.
 --
--- [API Overview]
+-- [API Overview For The Impatient]
 --
 -- Once started, a /managed process/ will consume messages from its mailbox and
 -- pass them on to user defined /handlers/ based on the types received (mapped
@@ -32,8 +32,8 @@
 --
 -- The 'ProcessAction' type defines the ways in which our process can respond
 -- to its inputs, whether by continuing to read incoming messages, setting an
--- optional timeout, sleeping for a while or stopping. The optional timeout
--- behaves a little differently to the other process actions. If no messages
+-- optional timeout, sleeping for a while, or stopping. The optional timeout
+-- behaves a little differently to the other process actions: If no messages
 -- are received within the specified time span, a user defined 'timeoutHandler'
 -- will be called in order to determine the next action.
 --
@@ -42,32 +42,129 @@
 -- returned 'stop' as the next action, or as the result of unhandled exit signal
 -- or similar asynchronous exceptions thrown in (or to) the process itself.
 --
--- The other handlers are split into two groups: /apiHandlers/ and /infoHandlers/.
--- The former contains handlers for the 'cast' and 'call' protocols, whilst the
--- latter contains handlers that deal with input messages which are not sent
--- via these API calls (i.e., messages sent using bare 'send' or signals put
--- into the process mailbox by the node controller, such as
--- 'ProcessMonitorNotification' and the like).
+-- The handlers are split into groups: /apiHandlers/, /infoHandlers/, and
+-- /extHandlers/.
 --
--- [The Cast/Call Protocol]
+-- [Seriously, TL;DR]
 --
--- Deliberate interactions with a /managed process/ usually fall into one of
+-- Use 'serve' for a process that sits reading its mailbox and generally behaves
+-- as you'd expect. Use 'pserve' and 'PrioritisedProcessDefinition' for a server
+-- that manages its mailbox more comprehensively and handles errors a bit differently.
+-- Both use the same client API.
+--
+-- DO NOT mask in handler code, unless you can guarantee it won't be long
+-- running and absolutely won't block kill signals from a supervisor.
+--
+-- Do look at the various API offerings, as there are several, at different
+-- levels of abstraction.
+--
+-- [Managed Process Mailboxes]
+--
+-- Managed processes come in two flavours, with different runtime characteristics
+-- and (to some extent) semantics. These flavours are differentiated by the way
+-- in which they handle the server process mailbox - all client interactions
+-- remain the same.
+--
+-- The /vanilla/ managed process mailbox, provided by the 'serve' API, is roughly
+-- akin to a tail recursive /listen/ function that calls a list of passed in
+-- matchers. We might naively implement it roughly like this:
+--
+-- >
+-- > loop :: stateT -> [(stateT -> Message -> Maybe stateT)] -> Process ()
+-- > loop state handlers = do
+-- >   st2 <- receiveWait $ map (\d -> handleMessage (d state)) handlers
+-- >   case st2 of
+-- >     Nothing -> {- we're done serving -} return ()
+-- >     Just s2 -> loop s2 handlers
+-- >
+--
+-- Obviously all the details have been ellided, but this is the essential premise
+-- behind a /managed process loop/. The process keeps reading from its mailbox
+-- indefinitely, until either a handler instructs it to stop, or an asynchronous
+-- exception (or exit signal - in the form of an async @ProcessExitException@)
+-- terminates it. This kind of mailbox has fairly intuitive runtime characteristics
+-- compared to a /plain server process/ (i.e. one implemented without the use of
+-- this library): messages will pile up in its mailbox whilst handlers are
+-- running, and each handler will be checked against the mailbox based on the
+-- type of messages it recognises. We can potentially end up scanning a very
+-- large mailbox trying to match each handler, which can be a performance
+-- bottleneck depending on expected traffic patterns.
+--
+-- For most simple server processes, this technique works well and is easy to
+-- reason about a use. See the sections on error and exit handling later on for
+-- more details about 'serve' based managed processes.
+--
+-- [Prioritised Mailboxes]
+--
+-- A prioritised mailbox serves two purposes. The first of these is to allow a
+-- managed process author to specify that certain classes of message should be
+-- prioritised by the server loop. This is achieved by draining the /real/
+-- process mailbox into an internal priority queue, and running the server's
+-- handlers repeatedly over its contents, which are dequeued in priority order.
+-- The obvious consequence of this approach leads to the second purpose (or the
+-- accidental side effect, depending on your point of view) of a prioritised
+-- mailbox, which is that we avoid scanning a large mailbox when searching for
+-- messages that match the handlers we anticipate running most frequently (or
+-- those messages that we deem most important).
+--
+-- There are several consequences to this approach. One is that we do quite a bit
+-- more work to manage the process mailbox behind the scenes, therefore we have
+-- additional space overhead to consider (although we are also reducing the size
+-- of the mailbox, so there is some counter balance here). The other is that if
+-- we do not see the anticipated traffic patterns at runtime, then we might
+-- spend more time attempting to prioritise infrequent messages than we would
+-- have done simply receiving them! We do however, gain a degree of safety with
+-- regards message loss that the 'serve' based /vanilla/ mailbox cannot offer.
+-- See the sections on error and exit handling later on for more details about
+-- these.
+--
+-- A Prioritised 'pserve' loop maintains its internal state - including the user
+-- defined /server state/ - in an @IORef@, ensuring it is held consistently
+-- between executions, even in the face of unhandled exceptions.
+--
+-- [Defining Prioritised Process Definitions]
+--
+-- A 'PrioritisedProcessDefintion' combines the usual 'ProcessDefintion' -
+-- containing the cast/call API, error, termination and info handlers - with a
+-- list of 'Priority' entries, which are used at runtime to prioritise the
+-- server's inputs. Note that it is only messages which are prioritised; The
+-- server's various handlers are still evaluated in the order in which they
+-- are specified in the 'ProcessDefinition'.
+--
+-- Prioritisation does not guarantee that a prioritised message/type will be
+-- processed before other traffic - indeed doing so in a multi-threaded runtime
+-- would be very hard - but in the absence of races between multiple processes,
+-- if two messages are both present in the process' own mailbox, they will be
+-- applied to the ProcessDefinition's handlers in priority order.
+--
+-- A prioritised process should probably be configured with a 'Priority' list to
+-- be useful. Creating a prioritised process without any priorities could be a
+-- potential waste of computational resources, and it is worth thinking carefully
+-- about whether or not prioritisation is truly necessary in your design before
+-- choosing to use it.
+--
+-- Using a prioritised process is as simple as calling 'pserve' instead of
+-- 'serve', and passing an initialised 'PrioritisedProcessDefinition'.
+--
+-- [The Cast and Call Protocols]
+--
+-- Deliberate interactions with a /managed process/ usually falls into one of
 -- two categories. A 'cast' interaction involves a client sending a message
 -- asynchronously and the server handling this input. No reply is sent to
 -- the client. On the other hand, a 'call' is a /remote procedure call/,
 -- where the client sends a message and waits for a reply from the server.
 --
--- All expressions given to @apiHandlers@ have to conform to the /cast|call/
+-- All expressions given to @apiHandlers@ have to conform to the /cast or call/
 -- protocol. The protocol (messaging) implementation is hidden from the user;
 -- API functions for creating user defined @apiHandlers@ are given instead,
 -- which take expressions (i.e., a function or lambda expression) and create the
 -- appropriate @Dispatcher@ for handling the cast (or call).
 --
--- These cast/call protocols are for dealing with /expected/ inputs. They
+-- These cast and call protocols are for dealing with /expected/ inputs. They
 -- will usually form the explicit public API for the process, and be exposed by
--- providing module level functions that defer to the cast/call API, giving
--- the author an opportunity to enforce the correct types. For
--- example:
+-- providing module level functions that defer to the cast or call client API,
+-- giving the process author an opportunity to enforce the correct input and
+-- response types. For example:
 --
 -- @
 -- {- Ask the server to add two numbers -}
@@ -94,7 +191,8 @@
 -- The cost of potential type mismatches between the client and server is the
 -- main disadvantage of this looser coupling between them. This mechanism does
 -- however, allow servers to handle a variety of messages without specifying the
--- entire protocol to be supported in excruciating detail.
+-- entire protocol to be supported in excruciating detail. For that, we would
+-- want /session types/, which are beyond the scope of this library.
 --
 -- [Handling Unexpected/Info Messages]
 --
@@ -103,7 +201,7 @@
 -- other kinds of messages from being sent to the process mailbox. When
 -- any message arrives for which there are no handlers able to process
 -- its content, the 'UnhandledMessagePolicy' will be applied. Sometimes
--- it is desireable to process incoming messages which aren't part of the
+-- it is desirable to process incoming messages which aren't part of the
 -- protocol, rather than let the policy deal with them. This is particularly
 -- true when incoming messages are important to the process, but their point
 -- of origin is outside the author's control. Handling /signals/ such as
@@ -137,7 +235,7 @@
 -- [Avoiding Side Effects]
 --
 -- If you wish to only write side-effect free code in your server definition,
--- then there is an explicit API for doing so. Instead of using the handlers
+-- then there is an explicit API for doing so. Instead of using the handler
 -- definition functions in this module, import the /pure/ server module instead,
 -- which provides a StateT based monad for building referentially transparent
 -- callbacks.
@@ -148,12 +246,8 @@
 -- [Handling Errors]
 --
 -- Error handling appears in several contexts and process definitions can
--- hook into these with relative ease. Only process failures as a result of
--- asynchronous exceptions are supported by the API, which provides several
--- scopes for error handling.
---
--- Catching exceptions inside handler functions is no different to ordinary
--- exception handling in monadic code.
+-- hook into these with relative ease. Catching exceptions inside handle
+-- functions is no different to ordinary exception handling in monadic code.
 --
 -- @
 --   handleCall (\\x y ->
@@ -163,7 +257,9 @@
 -- @
 --
 -- The caveats mentioned in "Control.Distributed.Process.Extras" about
--- exit signal handling obviously apply here as well.
+-- exit signal handling are very important here - it is strongly advised that
+-- you do not catch exceptions of type @ProcessExitException@ unless you plan
+-- to re-throw them again.
 --
 -- [Structured Exit Handling]
 --
@@ -172,11 +268,11 @@
 -- asynchronous exceptions. The 'ProcessDefinition' 'exitHandlers' field
 -- accepts a list of handlers that, for a specific exit reason, can decide
 -- how the process should respond. If none of these handlers matches the
--- type of @reason@ then the process will exit with @DiedException why@. In
+-- type of @reason@ then the process will exit. with @DiedException why@. In
 -- addition, a private /exit handler/ is installed for exit signals where
--- @reason :: ExitReason@, which is a form of /exit signal/ used explicitly
--- by the supervision APIs. This behaviour, which cannot be overriden, is to
--- gracefully shut down the process, calling the @shutdownHandler@ as usual,
+-- @(reason :: ExitReason) == ExitShutdown@, which is an of /exit signal/ used
+-- explicitly by supervision APIs. This behaviour, which cannot be overriden, is
+-- to gracefully shut down the process, calling the @shutdownHandler@ as usual,
 -- before stopping with @reason@ given as the final outcome.
 --
 -- /Example: handling custom data is @ProcessExitException@/
@@ -187,53 +283,92 @@
 -- Handling of /other/ forms of asynchronous exception (e.g., exceptions not
 -- generated by an /exit/ signal) is not supported by this API. Cloud Haskell's
 -- primitives for exception handling /will/ work normally in managed process
--- callbacks however.
+-- callbacks, but you are strongly advised against swallowing exceptions in
+-- general, or masking, unless you have carefully considered the consequences.
 --
--- If any asynchronous exception goes unhandled, the process will immediately
--- exit without running the @shutdownHandler@. It is very important to note
--- that in Cloud Haskell, link failures generate asynchronous exceptions in
--- the target and these will NOT be caught by the API and will therefore
--- cause the process to exit /without running the termination handler/
--- callback. If your termination handler is set up to do important work
--- (such as resource cleanup) then you should avoid linking you process
--- and use monitors instead.
+-- [Different Mailbox Types and Exceptions: Message Loss]
 --
--- [Prioritised Mailboxes]
---
--- Many processes need to prioritise certain classes of message over others,
--- so two subsets of the API are given to supporting those cases.
---
--- A 'PrioritisedProcessDefintion' combines the usual 'ProcessDefintion' -
--- containing the cast/call API, error, termination and info handlers - with a
--- list of 'Priority' entries, which are used at runtime to prioritise the
--- server's inputs. Note that it is only messages which are prioritised; The
--- server's various handlers are still evaluated in insertion order.
+-- Neither the /vanilla/ nor the /prioritised/ mailbox implementations will
+-- allow you to handle arbitrary asynchronous exceptions outside of your handler
+-- code. The way in which the two mailboxes handle unexpected asynchronous
+-- exceptions differs significantly however. The first consideration pertains to
+-- potential message loss.
 --
--- Prioritisation does not guarantee that a prioritised message/type will be
--- processed before other traffic - indeed doing so in a multi-threaded runtime
--- would be very hard - but in the absence of races between multiple processes,
--- if two messages are both present in the process' own mailbox, they will be
--- applied to the ProcessDefinition's handler's in priority order. This is
--- achieved by draining the real mailbox into a priority queue and processing
--- each message in turn.
+-- Consider a plain Cloud Haskell expression such as the following:
 --
--- A prioritised process must be configured with a 'Priority' list to be of
--- any use. Creating a prioritised process without any priorities would be a
--- big waste of computational resources, and it is worth thinking carefully
--- about whether or not prioritisation is truly necessary in your design before
--- choosing to use it.
---
--- Using a prioritised process is as simple as calling 'pserve' instead of
--- 'serve', and passing an initialised 'PrioritisedProcessDefinition'.
---
--- Note that prioritised process definitions cannot utilise control channels,
--- nor can the @handleExternal@ family of expressions be used with them. This
--- constraint is currenly not enforced by the compiler, and calling @pserve@
--- with a @ProcessDefinition@ containing any of these items will fail with
--- either @ExitOther "IllegalControlChannel"@ or @ExitOther "IllegalSTMAction"@
--- at runtime.
+-- @
+--   catch (receiveWait [ match (\(m :: SomeType) -> doSomething m) ])
+--         (\(e :: SomeCustomAsyncException) -> handleExFrom e pid)
+-- @
 --
--- [Control Channels]
+-- It is entirely possible that @receiveWait@ will succeed in matching a message
+-- of type @SomeType@ from the mailbox and removing it, to be handed to the
+-- supplied expression @doSomething@. Should an asynchronous exception arrive
+-- at this moment in time, though the handler might run and allow the server to
+-- recover, the message will be permanently lost.
+--
+-- The mailbox exposed by 'serve' operates in exactly this way, and as such it
+-- is advisible to avoid swallowing asynchronous exceptions, since doing so can
+-- introduce the possibility of unexpected message loss.
+--
+-- The prioritised mailbox exposed by 'pserve' on the other hand, does not suffer
+-- this scenario. Whilst the mailbox is drained into the internal priority queue,
+-- asynchronous exceptions are masked, and only once the queue has been updated
+-- are they removed. In addition, it is possible to @peek@ at the priority queue
+-- without removing a message, thereby ensuring that should the handler fail or
+-- an asynchronous exception arrive whilst processing the message, we can resume
+-- handling our message immediately upon recovering from the exception. This
+-- behaviour allows the process to guarantee against message loss, whilst avoiding
+-- masking within handlers, which is generally bad form (and can potentially lead
+-- to zombie processes, when supervised servers refuse to respond to @kill@
+-- signals whilst stuck in a long running handler).
+--
+-- Also note that a process' internal state is subject to the same semantics,
+-- such that the arrival of an asynchronous exception (including exit signals!)
+-- can lead to handlers (especially exit and shutdown handlers) running with
+-- a stale version of their state. For this reason - since we cannot guarantee
+-- an up to date state in the presence of these semantics - a shutdown handler
+-- for a 'serve' loop will always have its state passed as @LastKnown stateT@.
+--
+-- [Different Mailbox Types and Exceptions: Error Recovery And Shutdown]
+--
+-- If any asynchronous exception goes unhandled by a /vanilla/ process, the
+-- server will immediately exit without running the user supplied @shutdownHandler@.
+-- It is very important to note that in Cloud Haskell, link failures generate
+-- asynchronous exceptions in the target and these will NOT be caught by the 'serve'
+-- API and will therefore cause the process to exit /without running the
+-- termination handler/ callback. If your termination handler is set up to do
+-- important work (such as resource cleanup) then you should avoid linking you
+-- process and use monitors instead. If your code absolutely must run its
+-- termination handlers in the face of any unhandled (async) exception, consider
+-- using a prioritised mailbox, which handles this. Alternatively, consider
+-- arranging your processes in a supervision tree, and using a shutdown strategy
+-- to ensure that siblings terminate cleanly (based off a supervisor's ordered
+-- shutdown signal) in order to ensure cleanup code can run reliably.
+--
+-- As mentioned above, a prioritised mailbox behaves differently in the face
+-- of unhandled asynchronous exceptions. Whilst 'pserve' still offers no means
+-- for handling arbitrary async exceptions outside your handlers - and you should
+-- avoid handling them within, to the maximum extent possible - it does execute
+-- its receiving process in such a way that any unhandled exception will be
+-- caught and rethrown. Because of this, and the fact that a prioritised process
+-- manages its internal state in an @IORef@, shutdown handlers are guaranteed
+-- to run even in the face of async exceptions. These are run with the latest
+-- version of the server state available, given as @CleanShutdown stateT@ when
+-- the process is terminating normally (i.e. for reasons @ExitNormal@ or
+-- @ExitShutdown@), and @LastKnown stateT@ when an exception terminated the
+-- server process abruptly. The latter acknowledges that we cannot guarantee
+-- the exception did not interrupt us after the last handler ran and returned an
+-- updated state, but prior to storing the update.
+--
+-- Although shutdown handlers are run even in the face of unhandled exceptions
+-- (and prior to re-throwing, when there is one present), they are not run in a
+-- masked state. In fact, exceptions are explicitly unmasked prior to executing
+-- a handler, therefore it is possible for a shutdown handler to terminate
+-- abruptly. Once again, supervision hierarchies are a better way to ensure
+-- consistent cleanup occurs when valued resources are held by a process.
+--
+-- [Special Clients: Control Channels]
 --
 -- For advanced users and those requiring very low latency, a prioritised
 -- process definition might not be suitable, since it performs considerable
@@ -305,7 +440,7 @@
 -- >   sendControlMessage cp $ Request str sp
 -- >   receiveChan rp
 --
--- [External (STM) Input Channels]
+-- [Communicating with the outside world: External (STM) Input Channels]
 --
 -- Both client and server APIs provide a mechanism for interacting with a running
 -- server process via STM. This is primarily intended for code that runs outside
@@ -435,18 +570,15 @@ module Control.Distributed.Process.ManagedProcess
   , ProcessDefinition(..)
   , PrioritisedProcessDefinition(..)
   , RecvTimeoutPolicy(..)
-  , Priority(..)
+  , Priority()
   , DispatchPriority()
-  , Dispatcher()
-  , ExternDispatcher()
-  , DeferredDispatcher()
   , ShutdownHandler
   , TimeoutHandler
-  , ProcessAction(..)
-  , ProcessReply
   , Condition
   , Action
+  , ProcessAction()
   , Reply
+  , ProcessReply()
   , ActionHandler
   , CallHandler
   , CastHandler
@@ -458,66 +590,22 @@ module Control.Distributed.Process.ManagedProcess
   , StatelessChannelHandler
   , UnhandledMessagePolicy(..)
   , CallRef
-  , ControlChannel()
-  , ControlPort()
+  , ExitState(..)
+  , isCleanShutdown
+  , exitState
   , defaultProcess
   , defaultProcessWithPriorities
   , statelessProcess
   , statelessInit
     -- * Server side callbacks
-  , handleCall
-  , handleCallIf
-  , handleCallFrom
-  , handleCallFromIf
-  , handleCast
-  , handleCastIf
-  , handleInfo
-  , handleRaw
-  , handleRpcChan
-  , handleRpcChanIf
-  , action
-  , handleDispatch
-  , handleExit
-    -- * Stateless callbacks
-  , handleCall_
-  , handleCallFrom_
-  , handleCallIf_
-  , handleCallFromIf_
-  , handleCast_
-  , handleCastIf_
-  , handleRpcChan_
-  , handleRpcChanIf_
+  , module Control.Distributed.Process.ManagedProcess.Server
     -- * Control channels
+  , ControlChannel()
+  , ControlPort()
   , newControlChan
   , channelControlPort
-  , handleControlChan
-  , handleControlChan_
-    -- * Arbitrary STM actions
-  , handleExternal
-  , handleExternal_
-  , handleCallExternal
     -- * Prioritised mailboxes
   , module Control.Distributed.Process.ManagedProcess.Server.Priority
-    -- * Constructing handler results
-  , condition
-  , state
-  , input
-  , reply
-  , replyWith
-  , noReply
-  , noReply_
-  , haltNoReply_
-  , continue
-  , continue_
-  , timeoutAfter
-  , timeoutAfter_
-  , hibernate
-  , hibernate_
-  , stop
-  , stopWith
-  , stop_
-  , replyTo
-  , replyChan
   ) where
 
 import Control.Distributed.Process hiding (call, Message)
@@ -589,8 +677,9 @@ runProcess loop args init = do
     InitIgnore -> return ()
   where
     checkExitType :: ExitReason -> Process ()
-    checkExitType ExitNormal = return ()
-    checkExitType other      = die other
+    checkExitType ExitNormal   = return ()
+    checkExitType ExitShutdown = return ()
+    checkExitType other        = die other
 
 -- | A default 'ProcessDefinition', with no api, info or exit handler.
 -- The default 'timeoutHandler' simply continues, the 'shutdownHandler'
@@ -609,10 +698,6 @@ defaultProcess = ProcessDefinition {
 -- | Turns a standard 'ProcessDefinition' into a 'PrioritisedProcessDefinition',
 -- by virtue of the supplied list of 'DispatchPriority' expressions.
 --
--- Terminates the caller with an exit signal if the supplied process definition
--- contains any externHandlers, since these are not supported by prioritised
--- process definitions.
---
 prioritised :: ProcessDefinition s
             -> [DispatchPriority s]
             -> PrioritisedProcessDefinition s
@@ -621,7 +706,7 @@ prioritised def ps =
 
 -- | Sets the default 'recvTimeoutPolicy', which gives up after 10k reads.
 defaultRecvTimeoutPolicy :: RecvTimeoutPolicy
-defaultRecvTimeoutPolicy = RecvCounter 10000
+defaultRecvTimeoutPolicy = RecvMaxBacklog 10000
 
 -- | Creates a default 'PrioritisedProcessDefinition' from a list of
 -- 'DispatchPriority'. See 'defaultProcess' for the underlying definition.
diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 648cfc6..784934e 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -64,6 +64,9 @@ shutdown pid = cast pid Shutdown
 
 -- | Make a synchronous call - will block until a reply is received.
 -- The calling process will exit with 'ExitReason' if the calls fails.
+--
+-- __NOTE: this function does not catch exceptions!__
+--
 call :: forall s a b . (Addressable s, Serializable a, Serializable b)
                  => s -> a -> Process b
 call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 1143cc2..d4d4aa0 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -1,27 +1,69 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE Rank2Types                 #-}
 
 -- | This is the @Process@ implementation of a /managed process/
 module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
-  (recvLoop, precvLoop) where
-
-import Control.Applicative ((<$>))
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.STM hiding (check)
-import Control.Distributed.Process hiding (call, Message)
-import qualified Control.Distributed.Process as P (Message)
+  ( recvLoop
+  , precvLoop
+  , getState
+  , currentTimeout
+  , systemTimeout
+  , drainTimeout
+  , resetTimer
+  , GenProcess
+  ) where
+
+import Control.Distributed.Process
+  ( match
+  , matchAny
+  , matchMessage
+  , receiveTimeout
+  , receiveWait
+  , forward
+  , catchesExit
+  , Process
+  , ProcessId
+  , Match
+  )
+import qualified Control.Distributed.Process as P
+  ( liftIO
+  )
+import Control.Distributed.Process.Internal.Types
+  ( Message(..)
+  , ProcessExitException(..)
+  )
 import Control.Distributed.Process.ManagedProcess.Server
-import Control.Distributed.Process.ManagedProcess.Internal.Types
+  ( handleCast
+  , handleExitIf
+  , stop
+  , continue
+  )
+import Control.Distributed.Process.ManagedProcess.Timer
+  ( Timer(timerDelay)
+  , delayTimer
+  , startTimer
+  , stopTimer
+  , resetTimer
+  , matchTimeout
+  , TimedOut(..)
+  )
+import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (Message)
 import Control.Distributed.Process.Extras.Internal.Queue.PriorityQ
   ( PriorityQ
-  , enqueue
-  , dequeue
   )
-import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as PriorityQ
+import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as Q
   ( empty
+  , dequeue
+  , enqueue
   )
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
@@ -29,27 +71,198 @@ import Control.Distributed.Process.Extras
   )
 import qualified Control.Distributed.Process.Extras.SystemLog as Log
 import Control.Distributed.Process.Extras.Time
-import Control.Distributed.Process.Extras.Timer
-  ( cancelTimer
-  , runAfter
-  , TimerRef
-  )
 import Control.Monad (void)
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.Catch
+  ( mask_
+  , catch
+  , throwM
+  , uninterruptibleMask
+  , mask
+  , SomeException
+  , MonadThrow
+  , MonadCatch
+  , MonadMask
+  )
+import qualified Control.Monad.Catch as Catch
+  ( catch
+  , throwM
+  )
+import Control.Monad.IO.Class (MonadIO)
+import qualified Control.Monad.State.Strict as ST
+  ( MonadState
+  , StateT
+  , get
+  , lift
+  , runStateT
+  )
+import Data.IORef (IORef, newIORef, atomicModifyIORef')
 import Data.Typeable (Typeable)
-import Prelude hiding (init)
 
 --------------------------------------------------------------------------------
 -- Priority Mailbox Handling                                                  --
 --------------------------------------------------------------------------------
 
--- TODO: we need to actually utilise recvTimeout on the prioritised pdef, such
--- that a busy mailbox can't prevent us from operating normally.
+-- represent a max-backlog from RecvTimeoutPolicy
+type Limit = Maybe Int
+
+-- our priority queue
+type Queue = PriorityQ Int Message
+
+data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
+                                   , sysTimeout  :: Timer
+                                   , usrTimeout  :: Delay
+                                   , internalQ   :: Queue
+                                   , procState   :: s
+                                   , procDef     :: ProcessDefinition s
+                                   , procPrio    :: [DispatchPriority s]
+                                   }
+type State s = IORef (ProcessState s)
+
+newtype GenProcess s a = GenProcess {
+   unManaged :: ST.StateT (State s) Process a
+ }
+ deriving ( Functor
+          , Monad
+          , ST.MonadState (State s)
+          , MonadIO
+          , MonadFix
+          , Typeable
+          , Applicative
+          )
+
+instance forall s . MonadThrow (GenProcess s) where
+  throwM = lift . Catch.throwM
+
+instance forall s . MonadCatch (GenProcess s) where
+  catch p h = do
+    pSt <- ST.get
+    -- we can throw away our state since it is always accessed via an IORef
+    (a, _) <- lift $ Catch.catch (runProcess pSt p) (runProcess pSt . h)
+    return a
+
+instance forall s . MonadMask (GenProcess s) where
+  mask p = do
+      pSt <- ST.get
+      lift $ mask $ \restore -> do
+        (a, _) <- runProcess pSt (p (liftRestore restore))
+        return a
+    where
+      liftRestore restoreP = \p2 -> do
+        ourSTate <- ST.get
+        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
+        return a'
+
+  uninterruptibleMask p = do
+      pSt <- ST.get
+      (a, _) <- lift $ uninterruptibleMask $ \restore ->
+        runProcess pSt (p (liftRestore restore))
+      return a
+    where
+      liftRestore restoreP = \p2 -> do
+        ourSTate <- ST.get
+        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
+        return a'
+
+runProcess :: State s -> GenProcess s a -> Process (a, State s)
+runProcess state proc = ST.runStateT (unManaged proc) state
+
+lift :: Process a -> GenProcess s a
+lift p = GenProcess $ ST.lift p
+
+liftIO :: IO a -> GenProcess s a
+liftIO = lift . P.liftIO
+
+-- | Get the current process state
+getState :: forall s . GenProcess s (ProcessState s)
+getState = ST.get >>= \(s :: State s) -> liftIO $ do
+  atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', s')
+
+gets :: forall s a . (ProcessState s -> a) -> GenProcess s a
+gets f = ST.get >>= \(s :: State s) -> liftIO $ do
+  atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', f s' :: a)
+
+modifyState :: (ProcessState s -> ProcessState s) -> GenProcess s ()
+modifyState f =
+  ST.get >>= \s -> liftIO $ mask_ $ do
+    atomicModifyIORef' s $ \s' -> (f s', ())
+
+getAndModifyState :: (ProcessState s
+                  -> (ProcessState s, a)) -> GenProcess s a
+getAndModifyState f =
+  ST.get >>= \s -> liftIO $ mask_ $ do
+    atomicModifyIORef' s $ \s' -> f s'
+
+setProcessState :: s -> GenProcess s ()
+setProcessState st' =
+  modifyState $ \st@ProcessState{..} -> st { procState = st' }
+
+setDrainTimeout :: Timer -> GenProcess s ()
+setDrainTimeout t = modifyState $ \st@ProcessState{..} -> st { sysTimeout = t }
+
+setUserTimeout :: Delay -> GenProcess s ()
+setUserTimeout d =
+  modifyState $ \st@ProcessState{..} -> st { usrTimeout = d }
+
+processDefinition :: GenProcess s (ProcessDefinition s)
+processDefinition = gets procDef
+
+processPriorities :: GenProcess s ([DispatchPriority s])
+processPriorities = gets procPrio
+
+processState :: GenProcess s s
+processState = gets procState
+
+systemTimeout :: GenProcess s Timer
+systemTimeout = gets sysTimeout
+
+timeoutPolicy :: GenProcess s RecvTimeoutPolicy
+timeoutPolicy = gets timeoutSpec
+
+drainTimeout :: GenProcess s Delay
+drainTimeout = gets (timerDelay . sysTimeout)
+
+currentTimeout :: GenProcess s Delay
+currentTimeout = gets usrTimeout
+
+updateQueue :: (Queue -> Queue) -> GenProcess s ()
+updateQueue f =
+  modifyState $ \st@ProcessState{..} -> st { internalQ = f internalQ }
+
+--------------------------------------------------------------------------------
+-- Internal Priority Queue                                                    --
+--------------------------------------------------------------------------------
+
+dequeue :: GenProcess s (Maybe Message)
+dequeue =
+  getAndModifyState $ \st -> do
+    let pq = internalQ st
+    case Q.dequeue pq of
+      Nothing      -> (st, Nothing)
+      Just (m, q') -> (st { internalQ = q' }, Just m)
 
-type Queue = PriorityQ Int P.Message
-type TimeoutSpec = (Delay, Maybe (TimerRef, STM ()))
-data TimeoutAction s = Stop s ExitReason | Go Delay s
+enqueueMessage :: forall s . s
+               -> [DispatchPriority s]
+               -> Message
+               -> GenProcess s ()
+enqueueMessage s [] m' =
+  enqueueMessage s [ PrioritiseInfo {
+    prioritise = (\_ m ->
+      return $ Just ((-1 :: Int), m)) :: s -> Message -> Process (Maybe (Int, Message)) } ] m'
+enqueueMessage s (p:ps) m' = let checkPrio = prioritise p s in do
+    (lift $ checkPrio m') >>= doEnqueue s ps m'
+  where
+    doEnqueue :: s
+              -> [DispatchPriority s]
+              -> Message
+              -> Maybe (Int, Message)
+              -> GenProcess s ()
+    doEnqueue s' ps' msg Nothing       = enqueueMessage s' ps' msg
+    doEnqueue _  _   _   (Just (i, m)) = updateQueue (Q.enqueue (i * (-1 :: Int)) m)
 
-data CancelTimer = CancelTimer deriving (Eq, Show, Typeable)
+--------------------------------------------------------------------------------
+-- Process Loop Implementations                                               --
+--------------------------------------------------------------------------------
 
 -- | Prioritised process loop.
 --
@@ -61,277 +274,279 @@ data CancelTimer = CancelTimer deriving (Eq, Show, Typeable)
 -- unhandled exit signal or other form of failure condition (e.g. synchronous or
 -- asynchronous exceptions).
 --
-precvLoop :: PrioritisedProcessDefinition s -> s -> Delay -> Process ExitReason
-precvLoop ppDef pState recvDelay = do
-    tref <- startTimer recvDelay
-    recvQueue ppDef pState tref PriorityQ.empty
-
-{- note [flow control]
-
-This "receive loop" is a bit daunting, so we'll walk through it bit by bit.
-
-TL;DR we have a recursive structure of
-
-recvQueue >> processNext >>= nextAction
-      >>= recvQueueAux | return
-          recvQueueAux -> drainMessageQueue >>= recvQueue
-
-First recvQueue attempts to processNext, catching exits and returning
-ProcessStop ExitReason if they arrive. The result of processNext will be
-a triple of (ProcessAction state, delay, mailQueue).
-
-processNext checks to see if we've timed out, and if we have does the
-corresponding work (calling handlers, checks if we're stopping or continuing, etc.)
-If we're still running, it tries to dequeue the next message from the Internal
-mailQueue (a priority queue of messages) and if this succeeds, evaluates a
-handler and yields the resulting ProcessAction.
-
-If the internal mailQueue is empty, processNext evalutes drainOrTimeout, which
-performs a real 'receiveTimeout' and yields the next action (possibly enqueueing
-any received <<single>> message into mailQueue beforehand).
-
-When nextAction evaluates recvQueueAux, this uses drainMessageQueue to loop over
-the process mailbox (and any external matches, such as matchChan or matchSTM
-actions), enqueueing messages into mailQueue until no further mail is available,
-at which point it gives back the mailQueue.
-
-To prevent a DOS vector - and quite a likely accidental one at that - we do not
-sit draining the mailbox indefinitely, since a continuous stream of messages would
-leave us unable to process any inputs and we'd eventually run out of memory.
-Instead, the PrioritisedProcessDefinition holds a RecvTimeoutPolicy which can
-hold either a max-messages-processed limit or a timeout value. Using whichever
-policy is provided, drainMessageQueue will stop attempting to receive new mail
-either once the message count limit is exceeded or the timer expires, at which
-point we go back to processNext.
-
-A note on timeout handling (see the section, Simulated Receive Timeouts later):
-we utilise a combination of the Timer module (from -extras) and STM channels to
-handle timeouts in the mailbox draining loops. This means that for every time we
-go into the mailbox draining loop, we launch a peer process. The overheads are
-actually pretty low, but given the variety of work that we do here to handle
-prioritisation, the runtime profile of a process using this loop will differ
-/significantly/ from an ordinary recvLoop process.
-
-TODO: We have two timers for two different purposes - one that the handlers can
-specify as the [max time we should wait for mail before running a timeout
-handler], and another that ensures we don't get stuck draining messages forever.
-We should leverage just the one timer for this purpose, when the
-RecvTimeoutPolicy specifies one, and save ourselves two timers...
-
-TODO: ALSO! The timeout handling here is broken, because we don't listen for
-the server's timeout-spec channel in the drain mailbox implementation, which
-means we can arrive in processNext /long after the timeout should've expired/
-and then notice we'd hit it, and have to continue out of step...
-
-TODO: see nextAction for details on the two things above.
-
-NB: I THINK we can implement both timers using a single control plane, if we
-simply hold a broadcastTChan for writing and the readers dupTChan when they
-want to receive notifications. The channel can be polled easily during mailbox
-draining and written to safely by multiple writers that have dupTChan'd it
-
--}
-
-recvQueue :: PrioritisedProcessDefinition s
+-- ensureIOManagerIsRunning before evaluating this loop...
+--
+precvLoop :: PrioritisedProcessDefinition s
           -> s
-          -> TimeoutSpec
-          -> Queue
+          -> Delay
           -> Process ExitReason
-recvQueue p s t q =
-  let pDef = processDef p
-      ps   = priorities p
-  in do (ac, d, q') <- catchExit (processNext pDef ps s t q)
-                                 (\_ (r :: ExitReason) ->
-                                   return (ProcessStop r, Infinity, q))
-        nextAction ac d q'
+precvLoop ppDef pState recvDelay = do
+  st <- P.liftIO $ newIORef $ ProcessState { timeoutSpec = recvTimeout ppDef
+                                           , sysTimeout  = delayTimer Infinity
+                                           , usrTimeout  = recvDelay
+                                           , internalQ   = Q.empty
+                                           , procState   = pState
+                                           , procDef     = processDef ppDef
+                                           , procPrio    = priorities ppDef
+                                           }
+
+  -- Rewrite this code when this is fixed:
+  -- https://ghc.haskell.org/trac/ghc/ticket/10149
+  mask $ \restore -> do
+    res <- catch (fmap Right $ restore $ runProcess st recvQueue)
+                 (\(e :: SomeException) -> return $ Left e)
+
+    -- res could be (Left ex), so we restore process state & def from our IORef
+    ps <- P.liftIO $ atomicModifyIORef' st $ \s' -> (s', s')
+    let st' = procState ps
+        pd = procDef ps
+        sh = shutdownHandler pd
+    case res of
+      Right (exitReason, _) -> do
+        restore $ sh (CleanShutdown st') exitReason
+        return exitReason
+      Left ex -> do
+        -- we'll attempt to run the exit handler with the original state
+        restore $ sh (LastKnown st') (ExitOther $ show ex)
+        throwM ex
+
+recvQueue :: GenProcess s ExitReason
+recvQueue = do
+  pd <- processDefinition
+  let ex = trapExit:(exitHandlers $ pd)
+  let exHandlers = map (\d' -> (dispatchExit d')) ex
+
+  catch (drainMailbox >> processNext >>= nextAction)
+        (\(e :: ProcessExitException) ->
+            handleExit exHandlers e >>= nextAction)
   where
-{-
-REMOVED COMMENT FROM ABOVE ESSAY UNTIL IMPLEMENTED PROPERLY
-
-Also note that recvQueueAux will immediately pass control to processNext if the
-internal queue is non-empty, such that we favour processing message we've
-already received over reading our mailbox until we've emptied our internal
-queue, at which point our preference switches over to draining the real mailbox
-(and other input vectors) until we time out or hit the read size limit.
-
--}
-
-    nextAction ac d q'
-      -- TODO: if PQ.isEmpty q' == False, should we not continue working on
-      -- the mail we've already got?
-      -- that would mean evaluating something like
-      -- recvQueue ppDef pState (delay, Nothing) queue
-      | ProcessContinue  s'    <- ac = recvQueueAux p (priorities p) s' d  q'
-      | ProcessTimeout   t' s' <- ac = recvQueueAux p (priorities p) s' t' q'
-      | ProcessHibernate d' s' <- ac = block d' >> recvQueueAux p (priorities p) s' d q'
-      | ProcessStop      r     <- ac = (shutdownHandler $ processDef p) s r >> return r
-      | ProcessStopping  s' r  <- ac = (shutdownHandler $ processDef p) s' r >> return r
-      | otherwise {- compiler foo -} = die "IllegalState"
-
-    recvQueueAux ppDef prioritizers pState delay queue =
-        let pDef = processDef ppDef
-            ex   = trapExit:(exitHandlers $ pDef)
-            eh   = map (\d' -> (dispatchExit d') pState) ex
-            mx   = recvTimeout ppDef
-        in (do t' <- startTimer delay
-               mq <- drainMessageQueue mx pDef pState prioritizers queue
-               recvQueue ppDef pState t' mq)
-           `catchExit`
-           (\pid (reason :: ExitReason) -> do
-               let pd = processDef ppDef
-               let ps = pState
-               let pq = queue
-               let em = unsafeWrapMessage reason
-               (a, d, q') <- findExitHandlerOrStop pd ps pq eh pid em
-               nextAction a d q')
-
-    findExitHandlerOrStop :: ProcessDefinition s
-                          -> s
-                          -> Queue
-                          -> [ProcessId -> P.Message -> Process (Maybe (ProcessAction s))]
-                          -> ProcessId
-                          -> P.Message
-                          -> Process (ProcessAction s, Delay, Queue)
-    findExitHandlerOrStop _ _ pq [] _ er = do
-      mEr <- unwrapMessage er :: Process (Maybe ExitReason)
-      case mEr of
-        Nothing -> die "InvalidExitHandler"  -- TODO: better error message?
-        Just er' -> return (ProcessStop er', Infinity, pq)
-    findExitHandlerOrStop pd ps pq (eh:ehs) pid er = do
-      mAct <- eh pid er
-      case mAct of
-        Nothing -> findExitHandlerOrStop pd ps pq ehs pid er
-        Just pa -> return (pa, Infinity, pq)
-
-    processNext def ps' pState tSpec queue =
-      let ex = trapExit:(exitHandlers def)
-          h  = timeoutHandler def in do
-        -- as a side effect, this check will cancel the timer
-        timedOut <- checkTimer pState tSpec h
-        case timedOut of
-          Stop s' r -> return (ProcessStopping s' r, (fst tSpec), queue)
-          Go t' s'  ->
-            -- checkTimer could've run our timeoutHandler, which changes "s"
-            case dequeue queue of
-              Nothing ->
-                -- if the internal queue is empty, we fall back to reading the
-                -- actual mailbox, however if /that/ times out, then we need
-                -- to let the timeout handler kick in again and make a decision
-                drainOrTimeout def s' t' queue ps' h
-              Just (m', q') -> do
-                act <- catchesExit (processApply def s' m')
-                                   (map (\d' -> dispatchExit d' s') ex)
-                return (act, t', q')
+
+    handleExit :: [(s -> ProcessId -> Message -> Process (Maybe (ProcessAction s)))]
+               -> ProcessExitException
+               -> GenProcess s (ProcessAction s)
+    handleExit []     ex                                 = throwM ex
+    handleExit (h:hs) ex@(ProcessExitException pid msg) = do
+      r <- processState >>= \s -> lift $ h s pid msg
+      case r of
+        Nothing -> handleExit hs ex
+        Just p  -> return p
+
+    nextAction :: ProcessAction s -> GenProcess s ExitReason
+    nextAction ac
+      | ProcessSkip              <- ac = recvQueue
+      | ProcessContinue  ps'     <- ac = recvQueueAux ps'
+      | ProcessTimeout   d   ps' <- ac = setUserTimeout d >> recvQueueAux ps'
+      | ProcessStop      xr      <- ac = return xr
+      | ProcessStopping  ps' xr  <- ac = setProcessState ps' >> return xr
+      | ProcessHibernate d' s'   <- ac = (lift $ block d') >> recvQueueAux s'
+      | otherwise {- compiler foo -}   = return $ ExitOther "IllegalState"
+
+    recvQueueAux st = setProcessState st >> recvQueue
+
+      -- TODO: at some point we should re-implement our state monad in terms of
+      -- mkWeakIORef instead of a full IORef. At that point, we can implement hiberation
+      -- in the following terms:
+      -- 1. the user defines (at some level, perhaps outside of this API) some
+      --    means for writing a process' state to a backing store
+      --    NB: this could be /persistent/, or a file, or database, etc...
+      -- 2. when we enter hibernation, we do the following:
+      --    (a) write the process state to the chosen backing store
+      --    (b) evaluate yield (telling the RTS we're willing to give up our time slice)
+      --    (c) enter a blocking receiveWait with no state on our stack...
+      --        [NB] presumably at this point our state will be eligible for GC
+      --    (d) when we finally receive a message, reboot the process thus:
+      --        (i)   read our state back from the given backing store
+      --        (ii)  call a user defined function to rebuild the state if custom
+      --              actions need to be taken (e.g. they might've stored something
+      --              like an STM TVar and need to request a new one from some
+      --              well known service or registry - alt. they might want to
+      --              /replay/ actions to rebuild their state as an FSM might)
+      --        (iii) re-enter the recv loop and immediately processNext
+      --
+      -- This will give roughly the same semantics as erlang's hibernate/3, although
+      -- the RTS does GC globally rather than per-thread, but that might change in
+      -- some future release (who knows!?).
+      --
+      -- Also, this gives us the ability to migrate process state across remote
+      -- boundaries. Not only can a process be moved in this way, if we generalise
+      -- the mechanism to move a serialised closure, we can migrate the whole process
+      -- and its state as well. The main difference here (with ordinary use of
+      -- @Closure@ et al for moving processes around, is that we do not insist
+      -- on the process state being serializable, simply that they provide a
+      -- function to read+write the state, and a (state -> state) function to be
+      -- called during rehydration if custom actions need to be taken.
+      --
+
+    processNext :: GenProcess s (ProcessAction s)
+    processNext = do
+      next <- dequeue
+      case next of
+        Nothing -> drainOrTimeout
+        Just msg -> do
+          pd <- processDefinition
+          ps <- processState
+          processApply pd ps msg
 
     processApply def pState msg =
-      let pol          = unhandledMessagePolicy def
-          apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
-          infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
-          extMatchers  = map (dynHandleMessage pol pState) (externHandlers def)
-          shutdown'    = dynHandleMessage pol pState shutdownHandler'
-          ms'          = (shutdown':apiMatchers) ++ infoMatchers ++ extMatchers
-      in processApplyAux ms' pol pState msg
-
-    processApplyAux []     p' s' m' = applyPolicy p' s' m'
+     let pol          = unhandledMessagePolicy def
+         apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
+         infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
+         extMatchers  = map (dynHandleMessage pol pState) (externHandlers def)
+         shutdown'    = dynHandleMessage pol pState shutdownHandler'
+         ms'          = (shutdown':extMatchers) ++ apiMatchers ++ infoMatchers
+     in processApplyAux ms' pol pState msg
+
+    processApplyAux []     p' s' m' = lift $ applyPolicy p' s' m'
     processApplyAux (h:hs) p' s' m' = do
-      attempt <- h m'
-      case attempt of
-        Nothing  -> processApplyAux hs p' s' m'
-        Just act -> return act
-
-    drainOrTimeout pDef pState delay queue ps' h =
-      let p'       = unhandledMessagePolicy pDef
-          matches = ((matchMessage return):map (matchExtern p' pState) (externHandlers pDef))
-          recv    = case delay of
-                      Infinity -> fmap Just (receiveWait matches)
-                      NoDelay  -> receiveTimeout 0 matches
-                      Delay i  -> receiveTimeout (asTimeout i) matches in do
-        r <- recv
+     attempt <- lift $ h m'
+     case attempt of
+       Nothing  -> processApplyAux hs p' s' m'
+       Just act -> return act
+
+    drainMailbox :: GenProcess s ()
+    drainMailbox = do
+      -- see note [timer handling whilst draining the process' mailbox]
+      ps <- processState
+      pd <- processDefinition
+      pp <- processPriorities
+      let ms = matchAny (return . Right) : (mkMatchers ps pd)
+      timerAcc <- timeoutPolicy >>= \spec -> case spec of
+                                               RecvTimer      _   -> return Nothing
+                                               RecvMaxBacklog cnt -> return $ Just cnt
+      -- see note [handling async exceptions during non-blocking reads]
+      -- Also note that we only use the system timeout here, dropping into the
+      -- user timeout only if we end up in a blocking read on the mailbox.
+      --
+      mask_ $ do
+        tt <- maybeStartTimer
+        drainAux ps pp timerAcc (ms ++ matchTimeout tt)
+        (lift $ stopTimer tt) >>= setDrainTimeout
+
+    drainAux :: s
+             -> [DispatchPriority s]
+             -> Limit
+             -> [Match (Either TimedOut Message)]
+             -> GenProcess s ()
+    drainAux ps' pp' maxbq ms = do
+      (cnt, m) <- scanMailbox maxbq ms
+      case m of
+        Nothing                     -> return ()
+        Just (Left (_ :: TimedOut)) -> return ()
+        Just (Right m')             -> do enqueueMessage ps' pp' m'
+                                          drainAux ps' pp' cnt ms
+
+    maybeStartTimer :: GenProcess s Timer
+    maybeStartTimer = do
+      tp <- timeoutPolicy
+      t <- case tp of
+             RecvTimer d -> (lift $ startTimer $ Delay d)
+             _           -> return $ delayTimer Infinity
+      setDrainTimeout t
+      return t
+
+    scanMailbox :: Limit
+                -> [Match (Either TimedOut Message)]
+                -> GenProcess s (Limit, Maybe (Either TimedOut Message))
+    scanMailbox lim ms
+      | Just 0 <- lim = return (lim, Just $ Left TimedOut)
+      | Just c <- lim = do {- non-blocking read on our mailbox, any external inputs,
+                              plus whatever match specs the TimeoutManager gives -}
+                        lift $ fmap (Just (c - 1), ) (receiveTimeout 0 ms)
+      | otherwise     = lift $ fmap (lim, ) (receiveTimeout 0 ms)
+
+    -- see note [timer handling whilst draining the process' mailbox]
+    drainOrTimeout :: GenProcess s (ProcessAction s)
+    drainOrTimeout = do
+      pd <- processDefinition
+      ps <- processState
+      ud <- currentTimeout
+      let ump     = unhandledMessagePolicy pd
+          hto     = timeoutHandler pd
+          matches = ((matchMessage return):map (matchExtern ump ps) (externHandlers pd))
+          recv    = case ud of
+                      Infinity -> lift $ fmap Just (receiveWait matches)
+                      NoDelay  -> lift $ receiveTimeout 0 matches
+                      Delay i  -> lift $ receiveTimeout (asTimeout i) matches
+
+      -- see note [masking async exceptions during recv]
+      mask $ \restore -> recv >>= \r ->
         case r of
-          Nothing -> h pState delay >>= \act -> return (act, delay, queue)
+          Nothing -> restore $ lift $ hto ps ud
           Just m  -> do
-            queue' <- enqueueMessage pState ps' m queue
-            -- Returning @ProcessContinue@ simply causes the main loop to go
-            -- into 'recvQueueAux', which ends up in 'drainMessageQueue'.
-            -- In other words, we continue draining the /real/ mailbox.
-            return (ProcessContinue pState, delay, queue')
-
-drainMessageQueue :: RecvTimeoutPolicy
-                  -> ProcessDefinition s
-                  -> s
-                  -> [DispatchPriority s]
-                  -> Queue
-                  -> Process Queue
-drainMessageQueue limit pDef pState priorities' queue = do
-    timerAcc <- case limit of
-                  RecvTimer   tm  -> setupTimer tm
-                  RecvCounter cnt -> return $ Right cnt
-    drainMessageQueueAux pDef timerAcc pState priorities' queue
-
-  where
-
-    drainMessageQueueAux pd acc st ps q = do
-      (acc', m) <- drainIt st pd acc
-      -- say $ "drained " ++ show m
-      case m of
-        Nothing                 -> return q
-        Just (Left CancelTimer) -> return q
-        Just (Right m')         -> do
-          queue' <- enqueueMessage st ps m' q
-          drainMessageQueueAux pd acc' st ps queue'
-
-    drainIt :: s
-            -> ProcessDefinition s
-            -> Either (STM CancelTimer) Int
-            -> Process (Either (STM CancelTimer) Int,
-                        Maybe (Either CancelTimer P.Message))
-    drainIt _  _  e@(Right 0)  = return (e, Just (Left CancelTimer))
-    drainIt s' d' (Right cnt)  =
-      fmap (Right (cnt - 1), )
-           (receiveTimeout 0 (matchAny (return . Right): mkMatchers s' d'))
-    drainIt s' d' a@(Left stm) =
-      fmap (a, )
-           (receiveTimeout 0 ([ matchSTM stm (return . Left)
-                              , matchAny     (return . Right)
-                              ]  ++ mkMatchers s' d'))
+            pp <- processPriorities
+            enqueueMessage ps pp m
+            -- Returning @ProcessSkip@ simply causes us to go back into
+            -- listening mode until we hit RecvTimeoutPolicy
+            restore $ return ProcessSkip
 
     mkMatchers :: s
-               -> ProcessDefinition s
-               -> [Match (Either CancelTimer P.Message)]
+                -> ProcessDefinition s
+                -> [Match (Either TimedOut Message)]
     mkMatchers st df =
       map (matchMapExtern (unhandledMessagePolicy df) st toRight)
           (externHandlers df)
 
-    toRight :: P.Message -> Either CancelTimer P.Message
+    toRight :: Message -> Either TimedOut Message
     toRight = Right
 
-    setupTimer intv = do
-      chan <- liftIO newTChanIO
-      void $ runAfter intv $ liftIO $ atomically $ writeTChan chan CancelTimer
-      return $ Left (readTChan chan)
+-- note [handling async exceptions during non-blocking reads]
+-- Our golden rule is that if we've dequeued any kind of Message at all
+-- from the process mailbox (or input channels), we must not /lose/ it
+-- if an asynchronous exception arrives. We therefore mask  when we perform a
+-- non-blocking scan on the mailbox, and whilst we enqueue messages.
+--
+-- If an initial scan of the mailbox yields no data, we fall back to making
+-- a blocking read; See note [masking async exceptions during recv].
+--
+-- Once messages have been safely moved from the mailbox to our priority queue,
+-- we restore the masking state whilst running handlers.
+--
 
-enqueueMessage :: s
-               -> [DispatchPriority s]
-               -> P.Message
-               -> Queue
-               -> Process Queue
-enqueueMessage _ []     m' q = return $ enqueue (-1 :: Int) m' q
-enqueueMessage s (p:ps) m' q = let checkPrio = prioritise p s in do
-  checkPrio m' >>= maybeEnqueue s m' q ps
-  where
-    maybeEnqueue :: s
-                 -> P.Message
-                 -> Queue
-                 -> [DispatchPriority s]
-                 -> Maybe (Int, P.Message)
-                 -> Process Queue
-    maybeEnqueue s' msg q' ps' Nothing       = enqueueMessage s' ps' msg q'
-    maybeEnqueue _  _   q' _   (Just (i, m)) = return $ enqueue (i * (-1 :: Int)) m q'
+-- note [timer handling whilst draining the process' mailbox]
+-- To prevent a DOS vector - and quite a likely accidental one at that - we do not
+-- sit draining the mailbox indefinitely, since continuous reading would thus
+-- leave us unable to process any inputs and we'd eventually run out of memory.
+-- Instead, the PrioritisedProcessDefinition holds a RecvTimeoutPolicy which can
+-- hold either a max-messages-processed limit or a timeout value. Using whichever
+-- policy is provided, drainMessageQueue will stop attempting to receive new mail
+-- either once the message count limit is exceeded or the timer expires, at which
+-- point we go back to processNext.
+
+-- note [masking async exceptions during recv]
+-- Reading the process' mailbox is mask'ed anyway, however this only
+-- covers dequeue on the underlying CQueue, such that either before
+-- the dequeue takes place, or after (during evaluation of the result,
+-- or execution of the discovered @Match@ for the message), we can still
+-- be terminated by an asynchronous exception. This is wrong, from the
+-- perspective of a managed process, since in the case of an exit signal
+-- we might handle the exception, at which point we've dequeued and
+-- subsequently lost a message.
+--
+-- Masking recv then, prevents this from happening, and is relatively
+-- safe, because we know the following (having written all the handlers
+-- explicitly ourselves):
+--
+-- 1. each handler does nothing more than return the underlying message
+-- 2. in the most complex case, we have @Left . unsafeWrapMessage@ or
+--    @fmap Right readSTM thing@ inside of @matchSTM@
+-- 3. We should not, therefore, introduce any uninterruptible behaviour
+-- 4. We cannot, however, be certain that this holds true for decoding
+--    (and subsequent calls into Binary and/or Bytestrings), so at best
+--    we can mask, but not uninterruptibleMask
+--
+-- NB: According to /qnikst/, atomicModifyIORef' does not require us to
+-- use uninterruptibleMask anyway, so this is fine...
+--
 
 --------------------------------------------------------------------------------
 -- Ordinary/Blocking Mailbox Handling                                         --
 --------------------------------------------------------------------------------
 
+-- TODO: wrap recvLoop in the same exception handling as precvLoop
+--       notably, we need to ensure the shutdownHandler runs even in the face
+--       of exceptions, and it would be useful/good IMO to pass an IORef for
+--       the state, so we can have a decent LastKnown value for it
+
 -- | Managed process loop.
 --
 -- Evaluating this function will cause the caller to enter a server loop,
@@ -356,11 +571,12 @@ recvLoop pDef pState recvDelay =
     ac <- catchesExit (processReceive ms' handleTimeout pState recvDelay)
                       (map (\d' -> (dispatchExit d') pState) ex')
     case ac of
+        ProcessSkip              -> recvLoop pDef pState recvDelay -- TODO: handle differently...
         (ProcessContinue s')     -> recvLoop pDef s' recvDelay
         (ProcessTimeout t' s')   -> recvLoop pDef s' t'
         (ProcessHibernate d' s') -> block d' >> recvLoop pDef s' recvDelay
-        (ProcessStop r) -> handleStop pState r >> return (r :: ExitReason)
-        (ProcessStopping s' r)   -> handleStop s' r >> return (r :: ExitReason)
+        (ProcessStop r) -> handleStop (LastKnown pState) r >> return (r :: ExitReason)
+        (ProcessStopping s' r)   -> handleStop (LastKnown s') r >> return (r :: ExitReason)
   where
     matchAux :: UnhandledMessagePolicy
              -> s
@@ -368,10 +584,10 @@ recvLoop pDef pState recvDelay =
              -> [Match (ProcessAction s)]
     matchAux p ps ds = [matchAny (auxHandler (applyPolicy p ps) ps ds)]
 
-    auxHandler :: (P.Message -> Process (ProcessAction s))
+    auxHandler :: (Message -> Process (ProcessAction s))
                -> s
                -> [DeferredDispatcher s]
-               -> P.Message
+               -> Message
                -> Process (ProcessAction s)
     auxHandler policy _  [] msg = policy msg
     auxHandler policy st (d:ds :: [DeferredDispatcher s]) msg
@@ -409,46 +625,6 @@ recvLoop pDef pState recvDelay =
         NoDelay  -> receiveTimeout 0 matches
         Delay t' -> receiveTimeout (asTimeout t') matches
 
---------------------------------------------------------------------------------
--- Simulated Receive Timeouts                                                 --
---------------------------------------------------------------------------------
-
-startTimer :: Delay -> Process TimeoutSpec
-startTimer d
-  | Delay t <- d = do sig <- liftIO $ newEmptyTMVarIO
-                      tref <- runAfter t $ liftIO $ atomically $ putTMVar sig ()
-                      return (d, Just (tref, (readTMVar sig)))
-  | otherwise    = return (d, Nothing)
-
-checkTimer :: s
-           -> TimeoutSpec
-           -> TimeoutHandler s
-           -> Process (TimeoutAction s)
-checkTimer pState spec handler = let delay = fst spec in do
-  timedOut <- pollTimer spec  -- this will cancel the timer
-  case timedOut of
-    False -> go spec pState
-    True  -> do
-      act <- handler pState delay
-      case act of
-        ProcessTimeout   t' s' -> return $ Go t' s'
-        ProcessStop      r     -> return $ Stop pState r
-        ProcessStopping  s' r  -> return $ Stop s' r
-        ProcessHibernate d' s' -> block d' >> go spec s'
-        ProcessContinue  s'    -> go spec s'
-  where
-    go d s = return $ Go (fst d) s
-
-pollTimer :: TimeoutSpec -> Process Bool
-pollTimer (_, Nothing         ) = return False
-pollTimer (_, Just (tref, sig)) = do
-  cancelTimer tref  -- cancelling a dead/completed timer is a no-op
-  gotSignal <- liftIO $ atomically $ pollSTM sig
-  return $ maybe False (const True) gotSignal
-  where
-    pollSTM :: (STM ()) -> STM (Maybe ())
-    pollSTM sig' = (Just <$> sig') `orElse` return Nothing
-
 --------------------------------------------------------------------------------
 -- Utilities                                                                  --
 --------------------------------------------------------------------------------
@@ -459,14 +635,16 @@ shutdownHandler' = handleCast (\_ Shutdown -> stop $ ExitNormal)
 
 -- @(ProcessExitException from ExitShutdown)@ will stop the server gracefully
 trapExit :: ExitSignalDispatcher s
-trapExit = handleExit (\_ _ (r :: ExitReason) -> stop r)
+trapExit = handleExitIf (\_ e -> e == ExitShutdown)
+                        (\_ _ (r :: ExitReason) -> stop r)
 
 block :: TimeInterval -> Process ()
-block i = liftIO $ threadDelay (asTimeout i)
+block i =
+  void $ receiveTimeout (asTimeout i) [ match (\(_ :: TimedOut) -> return ()) ]
 
 applyPolicy :: UnhandledMessagePolicy
             -> s
-            -> P.Message
+            -> Message
             -> Process (ProcessAction s)
 applyPolicy p s m =
   case p of
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index e015007..456e3c5 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -27,6 +27,9 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , StatelessChannelHandler
   , InitHandler
   , ShutdownHandler
+  , ExitState(..)
+  , isCleanShutdown
+  , exitState
   , TimeoutHandler
   , UnhandledMessagePolicy(..)
   , ProcessDefinition(..)
@@ -141,14 +144,15 @@ data InitResult s =
   deriving (Typeable)
 
 -- | The action taken by a process after a handler has run and its updated state.
--- See 'continue'
---     'timeoutAfter'
---     'hibernate'
---     'stop'
---     'stopWith'
+-- See "Control.Distributed.Process.ManagedProcess.Server.continue"
+--     "Control.Distributed.Process.ManagedProcess.Server.timeoutAfter"
+--     "Control.Distributed.Process.ManagedProcess.Server.hibernate"
+--     "Control.Distributed.Process.ManagedProcess.Server.stop"
+--     "Control.Distributed.Process.ManagedProcess.Server.stopWith"
 --
 data ProcessAction s =
-    ProcessContinue  s              -- ^ continue with (possibly new) state
+    ProcessSkip
+  | ProcessContinue  s              -- ^ continue with (possibly new) state
   | ProcessTimeout   Delay        s -- ^ timeout if no messages are received
   | ProcessHibernate TimeInterval s -- ^ hibernate for /delay/
   | ProcessStop      ExitReason     -- ^ stop the process, giving @ExitReason@
@@ -169,6 +173,20 @@ data Condition s m =
   | State     (s -> Bool)       -- ^ predicated on the process state only
   | Input     (m -> Bool)       -- ^ predicated on the input message only
 
+-- | Informs a /shutdown handler/ of whether it is running due to a clean
+-- shutdown, or in response to an unhandled exception.
+data ExitState s = CleanShutdown s -- ^ given when an ordered shutdown is underway
+                 | LastKnown s     {-
+                  ^ given due to an unhandled exception, passing the last known state -}
+
+isCleanShutdown :: ExitState s -> Bool
+isCleanShutdown (CleanShutdown _) = True
+isCleanShutdown _                 = False
+
+exitState :: ExitState s -> s
+exitState (CleanShutdown s) = s
+exitState (LastKnown s)     = s
+
 -- | An action (server state transition) in the @Process@ monad
 type Action s = Process (ProcessAction s)
 
@@ -208,7 +226,7 @@ type StatelessChannelHandler s a b = SendPort b -> StatelessHandler s a
 type InitHandler a s = a -> Process (InitResult s)
 
 -- | An expression used to handle process termination
-type ShutdownHandler s = s -> ExitReason -> Process ()
+type ShutdownHandler s = ExitState s -> ExitReason -> Process ()
 
 -- | An expression used to handle process timeouts
 type TimeoutHandler s = ActionHandler s Delay
@@ -367,7 +385,7 @@ data DispatchPriority s =
 -- will stop removing messages from its mailbox and process those it has already
 -- received.
 --
-data RecvTimeoutPolicy = RecvCounter Int | RecvTimer TimeInterval
+data RecvTimeoutPolicy = RecvMaxBacklog Int | RecvTimer TimeInterval
   deriving (Typeable)
 
 -- | A @ProcessDefinition@ decorated with @DispatchPriority@ for certain
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 91de962..1939ba8 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -150,6 +150,10 @@ continue_ = return . ProcessContinue
 -- is exceeded. If no messages are handled during this period, the /timeout/
 -- handler will be called. Note that this alters the process timeout permanently
 -- such that the given @Delay@ will remain in use until changed.
+--
+-- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute
+-- immediately if no messages are present in the process' mailbox.
+--
 timeoutAfter :: Delay -> s -> Action s
 timeoutAfter d s = return $ ProcessTimeout d s
 
diff --git a/src/Control/Distributed/Process/ManagedProcess/Timer.hs b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
new file mode 100644
index 0000000..19b22ca
--- /dev/null
+++ b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Distributed.Process.ManagedProcess.Timer
+-- Copyright   :  (c) Tim Watson 2017
+-- License     :  BSD3 (see the file LICENSE)
+--
+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (requires concurrency)
+--
+-- This module provides a wrap around a simple 'Timer' that can be started,
+-- stopped, reset, cleared, and read. A convenient function is provided for
+-- creating a @Match@ expression for the timer.
+--
+-- [Notes]
+--
+-- The timers defined in this module are based on a @TVar Bool@. When the
+-- client program is @-threaded@ (i.e. @rtsSupportsBoundThreads == True@), then
+-- the timers are set using @registerDelay@, which is very efficient and relies
+-- only no the RTS IO Manager. When we're not @-threaded@, we fall back to using
+-- "Control.Distributed.Process.Extras.Timer" to set the @TVar@, which has much
+-- the same effect, but requires us to spawn a process to handle setting the
+-- @TVar@ - a process which could theoretically die before setting the variable.
+--
+module Control.Distributed.Process.ManagedProcess.Timer
+  ( Timer(timerDelay)
+  , delayTimer
+  , startTimer
+  , stopTimer
+  , resetTimer
+  , clearTimer
+  , matchTimeout
+  , isActive
+  , readTimer
+  , TimedOut(..)
+  ) where
+
+import Control.Concurrent (rtsSupportsBoundThreads)
+import Control.Concurrent.STM hiding (check)
+import Control.Distributed.Process
+  ( matchSTM
+  , Process
+  , ProcessId
+  , Match
+  , Message
+  , liftIO
+  )
+import qualified Control.Distributed.Process as P
+  ( liftIO
+  )
+import Control.Distributed.Process.Extras.Time (asTimeout, Delay(..))
+import Control.Distributed.Process.Extras.Timer
+  ( cancelTimer
+  , runAfter
+  , TimerRef
+  )
+import Data.Binary (Binary)
+import Data.Maybe (isJust, fromJust)
+import Data.Typeable (Typeable)
+import GHC.Conc (registerDelay)
+import GHC.Generics
+
+--------------------------------------------------------------------------------
+-- Timeout Management                                                         --
+--------------------------------------------------------------------------------
+
+-- private datum used during STM reads on Timers and to implement
+-- block in terms of listening for a message that will never arrive
+data TimedOut = TimedOut deriving (Eq, Show, Typeable, Generic)
+instance Binary TimedOut where
+
+-- | We hold timers in 2 states, each described by a Delay.
+-- isActive = isJust . mtSignal
+-- the TimerRef is optional since we only use the Timer module from extras
+-- when we're unable to registerDelay (i.e. not running under -threaded)
+data Timer = Timer { timerDelay  :: Delay
+                   , mtPidRef :: Maybe TimerRef
+                   , mtSignal :: Maybe (TVar Bool)
+                   }
+
+isActive :: Timer -> Bool
+isActive = isJust . mtSignal
+
+delayTimer :: Delay -> Timer
+delayTimer d = Timer d noPid noTVar
+  where
+    noPid  = Nothing :: Maybe ProcessId
+    noTVar = Nothing :: Maybe (TVar Bool)
+
+startTimer :: Delay -> Process Timer
+startTimer d
+  | Delay t <- d = establishTimer t
+  | otherwise    = return $ delayTimer d
+  where
+    establishTimer t'
+      | rtsSupportsBoundThreads = do sig <- liftIO $ registerDelay (asTimeout t')
+                                     return Timer { timerDelay = d
+                                                  , mtPidRef = Nothing
+                                                  , mtSignal = Just sig
+                                                  }
+      | otherwise = do
+          tSig  <- liftIO $ newTVarIO False
+          -- NB: runAfter spawns a process, which is defined in terms of
+          -- expectTimeout (asTimeout t) :: Process (Maybe CancelTimer)
+          --
+          tRef <- runAfter t' $ P.liftIO $ atomically $ writeTVar tSig True
+          return Timer { timerDelay  = d
+                       , mtPidRef = Just tRef
+                       , mtSignal = Just tSig
+                       }
+
+stopTimer :: Timer -> Process Timer
+stopTimer t@Timer{..} = do
+  clearTimer mtPidRef
+  return t { mtPidRef = Nothing
+           , mtSignal = Nothing
+           }
+
+resetTimer :: Timer -> Delay -> Process Timer
+resetTimer Timer{..} d = clearTimer mtPidRef >> startTimer d
+
+clearTimer :: Maybe TimerRef -> Process ()
+clearTimer ref
+  | isJust ref = cancelTimer (fromJust ref)
+  | otherwise  = return ()
+
+matchTimeout :: Timer -> [Match (Either TimedOut Message)]
+matchTimeout t@Timer{..}
+    | isActive t = [ matchSTM (readTimer $ fromJust mtSignal)
+                              (return . Left) ]
+    | otherwise  = []
+
+readTimer :: TVar Bool -> STM TimedOut
+readTimer t = do
+   expired <- readTVar t
+   if expired then return TimedOut
+              else retry
diff --git a/tests/Counter.hs b/tests/Counter.hs
index ecf4ac5..3f0a13a 100644
--- a/tests/Counter.hs
+++ b/tests/Counter.hs
@@ -86,10 +86,9 @@ serverDefinition = defaultProcess {
         ]
     } :: ProcessDefinition State
 
-haltMaxCount :: Process (ProcessReply Int State)
+haltMaxCount :: Reply Int State
 haltMaxCount = haltNoReply_ (ExitOther "Count > 10")
 
-handleIncrement :: State -> Increment -> Process (ProcessReply Int State)
+handleIncrement :: CallHandler State Increment Int 
 handleIncrement count Increment =
     let next = count + 1 in continue next >>= replyWith next
-
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 6f21baa..22c87ad 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -40,8 +40,8 @@ explodingTestProcess pid =
                      getSelfPid >>= \p -> die (p, i))
      ]
   , exitHandlers = [
-       handleExit  (\_ s (m :: String) -> send pid (m :: String) >>
-                                          continue s)
+       handleExit  (\_ s (m :: String) -> do send pid (m :: String)
+                                             continue s)
      , handleExit  (\_ s m@((_ :: ProcessId),
                             (_ :: Int)) -> P.send pid m >> continue s)
      ]
@@ -296,10 +296,16 @@ testSimpleErrorHandling :: Launcher ProcessId
 testSimpleErrorHandling launch result = do
   self <- getSelfPid
   (pid, exitReason) <- launch self
+  register "SUT" pid
+  sleep $ seconds 2
 
   -- this should be *altered* because of the exit handler
   Nothing <- callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String)
-  "foobar" <- expect
+
+  Right s <- awaitResponse pid [
+      matchIf (\(s :: String) -> s == "foobar")
+              (\s -> return (Right s) :: Process (Either ExitReason String))
+    ]
 
   shutdown pid
   waitForExit exitReason >>= stash result
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index aa9a9cc..0a9637d 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -74,7 +74,9 @@ explodingServer pid =
     exitReason <- liftIO newEmptyMVar
     spid <- spawnLocal $ do
        catch  (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal)
-              (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))
+              (\(e :: SomeException) -> do
+                -- say "died in handler..."
+                stash exitReason $ ExitOther (show e))
     return (spid, exitReason)
 
 data GetState = GetState
@@ -239,7 +241,7 @@ testTimedOverflowHandling result = do
 
 testOverflowHandling :: TestResult Bool -> Process ()
 testOverflowHandling result = do
-  pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvCounter 100 })
+  pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvMaxBacklog 100 })
   wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..50000] :: [Int])
 
   sleep $ seconds 1

From 7063cd548608ff2accecb15c2112e4a55fdfe61a Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Tue, 28 Feb 2017 17:03:18 +0000
Subject: [PATCH 43/50] Add support for rejecting call messages

---
 .../Process/ManagedProcess/Internal/Types.hs  |  9 ++++++++
 .../Process/ManagedProcess/Server.hs          | 21 +++++++++++++++++--
 tests/ManagedProcessCommon.hs                 | 14 +++++++++++++
 tests/TestManagedProcess.hs                   |  3 +++
 tests/TestPrioritisedProcess.hs               |  3 +++
 5 files changed, 48 insertions(+), 2 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 456e3c5..be8630a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -52,6 +52,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , CallResponse(..)
   , CallId
   , CallRef(..)
+  , CallRejected(..)
   , makeRef
   , initCall
   , unsafeInitCall
@@ -126,6 +127,11 @@ instance NFSerializable a => NFData (CallResponse a) where
 deriving instance Eq a => Eq (CallResponse a)
 deriving instance Show a => Show (CallResponse a)
 
+data CallRejected = CallRejected String CallId
+  deriving (Typeable, Generic, Show, Eq)
+instance Binary CallRejected where
+instance NFData CallRejected where
+
 instance Resolvable (CallRef a) where
   resolve (CallRef (r, _)) = resolve r
 
@@ -163,6 +169,7 @@ data ProcessAction s =
 -- can return @NoReply@ if they wish to ignore the call.
 data ProcessReply r s =
     ProcessReply r (ProcessAction s)
+  | ProcessReject String (ProcessAction s)
   | NoReply (ProcessAction s)
 
 -- | Wraps a predicate that is used to determine whether or not a handler
@@ -471,6 +478,8 @@ waitResponse mTimeout cRef =
   let (_, mRef) = unCaller cRef
       matchers  = [ matchIf (\((CallResponse _ ref) :: CallResponse b) -> ref == mRef)
                             (\((CallResponse m _) :: CallResponse b) -> return (Right m))
+                  , matchIf (\((CallRejected _ ref)) -> ref == mRef)
+                            (\(CallRejected s _) -> return (Left $ ExitOther $ s))
                   , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
                       (\(ProcessMonitorNotification _ _ r) -> return (Left (err r)))
                   ]
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 1939ba8..dd2a9d1 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE PatternGuards              #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -29,6 +30,8 @@ module Control.Distributed.Process.ManagedProcess.Server
   , stopWith
   , replyTo
   , replyChan
+  , reject
+  , rejectWith
     -- * Stateless actions
   , noReply_
   , haltNoReply_
@@ -78,8 +81,10 @@ import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
   , Routable(..)
+  , Resolvable(..)
   )
 import Control.Distributed.Process.Extras.Time
+import Data.Maybe (fromJust)
 import Prelude hiding (init)
 
 --------------------------------------------------------------------------------
@@ -112,6 +117,12 @@ state = State
 input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m
 input = Input
 
+reject :: forall r s . s -> String -> Reply r s
+reject st rs = continue st >>= \s -> return $ ProcessReject rs s
+
+rejectWith :: forall r m s . (Show m) => s -> m -> Reply r s
+rejectWith st rs = continue st >>= \s -> return $ ProcessReject (show rs) s
+
 -- | Instructs the process to send a reply and continue running.
 reply :: (Serializable r) => r -> s -> Reply r s
 reply r s = continue s >>= replyWith r
@@ -448,6 +459,7 @@ handleCallExternal reader writer handler =
     doStmReply d s m = d s m >>= doXfmReply writer
 
     doXfmReply _ (NoReply a)         = return a
+    doXfmReply _ (ProcessReject _ a) = return a
     doXfmReply w (ProcessReply r' a) = liftIO (atomically $ w r') >> return a
 
 -- | Constructs a /control channel/ handler from a function in the
@@ -603,8 +615,13 @@ mkReply :: (Serializable b)
         => CallRef b
         -> ProcessReply b s
         -> Process (ProcessAction s)
-mkReply _ (NoReply a)         = return a
-mkReply c (ProcessReply r' a) = sendTo c r' >> return a
+mkReply cRef act
+  | (NoReply a)          <- act   = return a
+  | (ProcessReply  r' a) <- act   = sendTo cRef r' >> return a
+  | (CallRef (_, tag))   <- cRef
+  , (ProcessReject s' a) <- act   = resolve cRef >>= \p ->
+      send (fromJust p) (CallRejected s' tag) >> return a
+  | otherwise                     = die $ ExitOther "mkReply.InvalidState"
 
 -- these functions are the inverse of 'condition', 'state' and 'input'
 
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 22c87ad..0132594 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -60,6 +60,8 @@ standardTestServer policy =
             , handleCall    (\s' (m :: String) -> reply m s')
             , handleCall_   (\(n :: Int) -> return (n * 2))    -- "stateless"
 
+            , handleCall    (\s' (_ :: Delay) -> (reject s' "invalid-call") :: Reply () ())
+
             , handleCast    (\s' ("ping", pid :: ProcessId) ->
                                  send pid "pong" >> continue s')
             , handleCastIf_ (input (\(c :: String, _ :: Delay) -> c == "timeout"))
@@ -357,3 +359,15 @@ testUnsafeAlternativeErrorHandling launch result = do
 
   Unsafe.shutdown pid
   waitForExit exitReason >>= stash result
+
+testServerRejectsMessage :: Launcher ProcessId
+                         -> TestResult ExitReason
+                         -> Process ()
+testServerRejectsMessage launch result = do
+  self <- getSelfPid
+  (pid, _) <- launch self
+
+  -- server is configured to reject (m :: Delay)
+  Left res <- safeCall pid Infinity :: Process (Either ExitReason ())
+  say $ show res
+  stash result res
diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs
index 880d5dc..125c176 100644
--- a/tests/TestManagedProcess.hs
+++ b/tests/TestManagedProcess.hs
@@ -319,6 +319,9 @@ tests transport = do
           , testCase "(unsafe) long running call cancellation"
             (delayedAssertion "expected to get AsyncCancelled"
             localNode True (testUnsafeKillMidCall $ wrap server))
+          , testCase "server rejects call"
+              (delayedAssertion "expected server to send CallRejected"
+              localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server))
           , testCase "invalid return type handling"
             (delayedAssertion
              "expected response to fail on runtime type verification"
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 0a9637d..490a107 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -334,6 +334,9 @@ tests transport = do
           , testCase "long running call cancellation"
             (delayedAssertion "expected to get AsyncCancelled"
              localNode True (testKillMidCall $ wrap server))
+          , testCase "server rejects call"
+             (delayedAssertion "expected server to send CallRejected"
+              localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server))             
           , testCase "simple exit handling"
             (delayedAssertion "expected handler to catch exception and continue"
              localNode Nothing (testSimpleErrorHandling $ explodingServer))

From 90bca8ccbc0c9cfadbfb217419b62881c090bfe8 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Wed, 1 Mar 2017 14:25:51 +0000
Subject: [PATCH 44/50] Support for message filtering

Applied before handlers, with the posibility of altering the server's behaviour
(e.g. pre-emping, rejecting inputs, etc), filters can be used only by the
prioritised process definition.
---
 .../Distributed/Process/ManagedProcess.hs     |   2 +-
 .../ManagedProcess/Internal/GenProcess.hs     | 101 +++++++++++++-----
 .../Process/ManagedProcess/Internal/Types.hs  |  61 ++++++++++-
 .../Process/ManagedProcess/Server.hs          |  16 +--
 tests/ManagedProcessCommon.hs                 |   1 -
 5 files changed, 142 insertions(+), 39 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index c0808b9..455d59b 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -702,7 +702,7 @@ prioritised :: ProcessDefinition s
             -> [DispatchPriority s]
             -> PrioritisedProcessDefinition s
 prioritised def ps =
-  PrioritisedProcessDefinition def ps defaultRecvTimeoutPolicy
+  PrioritisedProcessDefinition def ps [] defaultRecvTimeoutPolicy
 
 -- | Sets the default 'recvTimeoutPolicy', which gives up after 10k reads.
 defaultRecvTimeoutPolicy :: RecvTimeoutPolicy
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index d4d4aa0..505e625 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -22,6 +22,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   , GenProcess
   ) where
 
+import Control.Applicative (liftA3)
 import Control.Distributed.Process
   ( match
   , matchAny
@@ -64,6 +65,7 @@ import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as
   ( empty
   , dequeue
   , enqueue
+  , peek
   )
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
@@ -97,6 +99,7 @@ import qualified Control.Monad.State.Strict as ST
   , runStateT
   )
 import Data.IORef (IORef, newIORef, atomicModifyIORef')
+import Data.Maybe (fromJust)
 import Data.Typeable (Typeable)
 
 --------------------------------------------------------------------------------
@@ -116,6 +119,7 @@ data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
                                    , procState   :: s
                                    , procDef     :: ProcessDefinition s
                                    , procPrio    :: [DispatchPriority s]
+                                   , procFilters :: [DispatchFilter s]
                                    }
 type State s = IORef (ProcessState s)
 
@@ -210,9 +214,15 @@ processDefinition = gets procDef
 processPriorities :: GenProcess s ([DispatchPriority s])
 processPriorities = gets procPrio
 
+processFilters :: GenProcess s ([DispatchFilter s])
+processFilters = gets procFilters
+
 processState :: GenProcess s s
 processState = gets procState
 
+processUnhandledMsgPolicy :: GenProcess s UnhandledMessagePolicy
+processUnhandledMsgPolicy = gets (unhandledMessagePolicy . procDef)
+
 systemTimeout :: GenProcess s Timer
 systemTimeout = gets sysTimeout
 
@@ -234,12 +244,16 @@ updateQueue f =
 --------------------------------------------------------------------------------
 
 dequeue :: GenProcess s (Maybe Message)
-dequeue =
-  getAndModifyState $ \st -> do
-    let pq = internalQ st
-    case Q.dequeue pq of
-      Nothing      -> (st, Nothing)
-      Just (m, q') -> (st { internalQ = q' }, Just m)
+dequeue = getAndModifyState $ \st -> do
+            let pq = internalQ st
+            case Q.dequeue pq of
+              Nothing      -> (st, Nothing)
+              Just (m, q') -> (st { internalQ = q' }, Just m)
+
+peek :: GenProcess s (Maybe Message)
+peek = getAndModifyState $ \st -> do
+         let pq = internalQ st
+         (st, Q.peek pq)
 
 enqueueMessage :: forall s . s
                -> [DispatchPriority s]
@@ -288,6 +302,7 @@ precvLoop ppDef pState recvDelay = do
                                            , procState   = pState
                                            , procDef     = processDef ppDef
                                            , procPrio    = priorities ppDef
+                                           , procFilters = filters    ppDef
                                            }
 
   -- Rewrite this code when this is fixed:
@@ -379,22 +394,56 @@ recvQueue = do
 
     processNext :: GenProcess s (ProcessAction s)
     processNext = do
-      next <- dequeue
+      (up, fs, ps) <- gets (liftA3 (,,) (unhandledMessagePolicy . procDef)
+                                         procFilters
+                                         procState)
+      case fs of
+        [] -> consumeMessage
+        _  -> filterMessage  (filterNext up fs Nothing)
+
+    consumeMessage = applyNext dequeue processApply
+    filterMessage = applyNext peek
+
+    filterNext :: UnhandledMessagePolicy
+               -> [DispatchFilter s]
+               -> Maybe (Filter s)
+               -> Message
+               -> GenProcess s (ProcessAction s)
+    filterNext mp' fs act msg
+      | Just (FilterSkip s') <- act = {- state!!!!! -} dequeue >> return ProcessSkip
+      | Just (FilterOk s')   <- act
+      , []                   <- fs = setProcessState s' >> applyNext dequeue processApply
+      | Nothing <- act, []   <- fs = applyNext dequeue processApply
+      | Just (FilterOk s')   <- act
+      , (f:fs')              <- fs = do
+          setProcessState s'
+          act' <- lift $ dynHandleFilter s' f msg
+          filterNext mp' fs' act' msg
+      | Just (FilterReject s') <- act = do
+          setProcessState s' >> dequeue >>= lift . applyPolicy mp' s' . fromJust
+      | Nothing <- act {- filter didn't apply to the input type -}
+      , (f:fs') <- fs = processState >>= \s' -> do
+          lift (dynHandleFilter s' f msg) >>= \a -> filterNext mp' fs' a msg
+
+    applyNext :: (GenProcess s (Maybe Message))
+              -> (Message -> GenProcess s (ProcessAction s))
+              -> GenProcess s (ProcessAction s)
+    applyNext queueOp handler = do
+      next <- queueOp
       case next of
-        Nothing -> drainOrTimeout
-        Just msg -> do
-          pd <- processDefinition
-          ps <- processState
-          processApply pd ps msg
-
-    processApply def pState msg =
-     let pol          = unhandledMessagePolicy def
-         apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
-         infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
-         extMatchers  = map (dynHandleMessage pol pState) (externHandlers def)
-         shutdown'    = dynHandleMessage pol pState shutdownHandler'
-         ms'          = (shutdown':extMatchers) ++ apiMatchers ++ infoMatchers
-     in processApplyAux ms' pol pState msg
+        Nothing  -> drainOrTimeout
+        Just msg -> handler msg
+
+    processApply msg = do
+      def <- processDefinition
+      pState <- processState
+      let pol          = unhandledMessagePolicy def
+          apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
+          infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
+          extMatchers  = map (dynHandleMessage pol pState) (externHandlers def)
+          shutdown'    = dynHandleMessage pol pState shutdownHandler'
+          ms'          = (shutdown':extMatchers) ++ apiMatchers ++ infoMatchers
+      processApplyAux ms' pol pState msg
 
     processApplyAux []     p' s' m' = lift $ applyPolicy p' s' m'
     processApplyAux (h:hs) p' s' m' = do
@@ -571,12 +620,12 @@ recvLoop pDef pState recvDelay =
     ac <- catchesExit (processReceive ms' handleTimeout pState recvDelay)
                       (map (\d' -> (dispatchExit d') pState) ex')
     case ac of
-        ProcessSkip              -> recvLoop pDef pState recvDelay -- TODO: handle differently...
-        (ProcessContinue s')     -> recvLoop pDef s' recvDelay
-        (ProcessTimeout t' s')   -> recvLoop pDef s' t'
-        (ProcessHibernate d' s') -> block d' >> recvLoop pDef s' recvDelay
+        ProcessSkip               -> recvLoop pDef pState recvDelay -- TODO: handle differently...
+        (ProcessContinue s')      -> recvLoop pDef s' recvDelay
+        (ProcessTimeout t' s')    -> recvLoop pDef s' t'
+        (ProcessHibernate d' s')  -> block d' >> recvLoop pDef s' recvDelay
         (ProcessStop r) -> handleStop (LastKnown pState) r >> return (r :: ExitReason)
-        (ProcessStopping s' r)   -> handleStop (LastKnown s') r >> return (r :: ExitReason)
+        (ProcessStopping s' r)    -> handleStop (LastKnown s') r >> return (r :: ExitReason)
   where
     matchAux :: UnhandledMessagePolicy
              -> s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index be8630a..d53e7e9 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -35,6 +35,8 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , ProcessDefinition(..)
   , Priority(..)
   , DispatchPriority(..)
+  , DispatchFilter(..)
+  , Filter(..)
   , PrioritisedProcessDefinition(..)
   , RecvTimeoutPolicy(..)
   , ControlChannel(..)
@@ -48,12 +50,16 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , MessageMatcher(..)
   , ExternMatcher(..)
   , DynMessageHandler(..)
+  , DynFilterHandler(..)
   , Message(..)
   , CallResponse(..)
   , CallId
   , CallRef(..)
   , CallRejected(..)
   , makeRef
+  , caller
+  , recipient
+  , tag
   , initCall
   , unsafeInitCall
   , waitResponse
@@ -95,6 +101,12 @@ type CallId = MonitorRef
 newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }
   deriving (Eq, Show, Typeable, Generic)
 
+recipient :: CallRef a -> Recipient
+recipient = fst . unCaller
+
+tag :: CallRef a -> CallId
+tag = snd . unCaller
+
 instance Binary (CallRef a) where
 instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` ()
 
@@ -109,6 +121,10 @@ data Message a b =
   | ChanMessage a (SendPort b)
   deriving (Typeable, Generic)
 
+caller :: Message a b -> Maybe (CallRef b)
+caller (CallMessage _ ref) = Just ref
+caller _                   = Nothing
+
 instance (Serializable a, Serializable b) => Binary (Message a b) where
 instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where
   rnf (CastMessage a) = rnf a `seq` ()
@@ -136,8 +152,8 @@ instance Resolvable (CallRef a) where
   resolve (CallRef (r, _)) = resolve r
 
 instance Routable (CallRef a) where
-  sendTo  (CallRef (client, tag)) msg = sendTo client (CallResponse msg tag)
-  unsafeSendTo (CallRef (c, tag)) msg = unsafeSendTo c (CallResponse msg tag)
+  sendTo (CallRef (c, _)) = sendTo c
+  unsafeSendTo (CallRef (c, _)) = unsafeSendTo c
 
 -- | Return type for and 'InitHandler' expression.
 data InitResult s =
@@ -169,7 +185,7 @@ data ProcessAction s =
 -- can return @NoReply@ if they wish to ignore the call.
 data ProcessReply r s =
     ProcessReply r (ProcessAction s)
-  | ProcessReject String (ProcessAction s)
+  | ProcessReject String (ProcessAction s)  -- TODO: can we use a functional dependency here?
   | NoReply (ProcessAction s)
 
 -- | Wraps a predicate that is used to determine whether or not a handler
@@ -282,6 +298,30 @@ data Dispatcher s =
     , dispatchIf :: s -> Message a b -> Bool
     }
 
+data Filter s = FilterOk s
+              | FilterReject s
+              | FilterSkip s
+
+data DispatchFilter s =
+    forall a b . (Serializable a, Serializable b) =>
+    FilterApi
+    {
+      apiFilter :: s -> Message a b -> Process (Filter s)
+    }
+  | forall a . (Serializable a) =>
+    FilterAny
+    {
+      anyFilter :: s -> a -> Process (Filter s)
+    }
+  | FilterRaw
+    {
+      rawFilter :: s -> P.Message -> Process (Maybe (Filter s))
+    }
+  | FilterState
+    {
+      stateFilter :: s -> Process (Maybe (Filter s))
+    }
+
 -- | Provides dispatch for channels and STM actions
 data ExternDispatcher s =
     forall a b . (Serializable a, Serializable b) =>
@@ -363,6 +403,20 @@ instance DynMessageHandler ExternDispatcher where
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
 
+-- | Maps filters to an action that can take place outside of a
+-- expect/recieve block.
+class DynFilterHandler d where
+  dynHandleFilter :: s
+                  -> d s
+                  -> P.Message
+                  -> Process (Maybe (Filter s))
+
+instance DynFilterHandler DispatchFilter where
+  dynHandleFilter s (FilterApi d)   msg = handleMessage msg (d s)
+  dynHandleFilter s (FilterAny d)   msg = handleMessage msg (d s)
+  dynHandleFilter s (FilterRaw d)   msg = d s msg
+  dynHandleFilter s (FilterState d) _   = d s
+
 -- | Priority of a message, encoded as an @Int@
 newtype Priority a = Priority { getPrio :: Int }
 
@@ -402,6 +456,7 @@ data PrioritisedProcessDefinition s =
   {
     processDef  :: ProcessDefinition s
   , priorities  :: [DispatchPriority s]
+  , filters     :: [DispatchFilter s]
   , recvTimeout :: RecvTimeoutPolicy
   }
 
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index dd2a9d1..518a985 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -118,10 +118,10 @@ input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m
 input = Input
 
 reject :: forall r s . s -> String -> Reply r s
-reject st rs = continue st >>= \s -> return $ ProcessReject rs s
+reject st rs = continue st >>= return . ProcessReject rs
 
-rejectWith :: forall r m s . (Show m) => s -> m -> Reply r s
-rejectWith st rs = continue st >>= \s -> return $ ProcessReject (show rs) s
+rejectWith :: forall r m s . (Show r) => s -> r -> Reply m s
+rejectWith st rs = reject st (show rs)
 
 -- | Instructs the process to send a reply and continue running.
 reply :: (Serializable r) => r -> s -> Reply r s
@@ -616,12 +616,12 @@ mkReply :: (Serializable b)
         -> ProcessReply b s
         -> Process (ProcessAction s)
 mkReply cRef act
-  | (NoReply a)          <- act   = return a
-  | (ProcessReply  r' a) <- act   = sendTo cRef r' >> return a
+  | (NoReply a)          <- act  = return a
   | (CallRef (_, tag))   <- cRef
-  , (ProcessReject s' a) <- act   = resolve cRef >>= \p ->
-      send (fromJust p) (CallRejected s' tag) >> return a
-  | otherwise                     = die $ ExitOther "mkReply.InvalidState"
+  , (ProcessReply  r' a) <- act  = sendTo cRef (CallResponse r' tag) >> return a
+  | (CallRef (_, tag))   <- cRef
+  , (ProcessReject r' a) <- act  = sendTo cRef (CallRejected r' tag) >> return a
+  | otherwise                    = die $ ExitOther "mkReply.InvalidState"
 
 -- these functions are the inverse of 'condition', 'state' and 'input'
 
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 0132594..84f0baf 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -369,5 +369,4 @@ testServerRejectsMessage launch result = do
 
   -- server is configured to reject (m :: Delay)
   Left res <- safeCall pid Infinity :: Process (Either ExitReason ())
-  say $ show res
   stash result res

From ad4fe18886f4f2eab24b0e5c782cee96cc097b91 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Wed, 1 Mar 2017 20:34:36 +0000
Subject: [PATCH 45/50] Input filters/checks API - work in progress

---
 .../Distributed/Process/ManagedProcess.hs     |   3 +-
 .../ManagedProcess/Internal/GenProcess.hs     |  19 ++-
 .../Process/ManagedProcess/Internal/Types.hs  |  84 +++++++++----
 .../Process/ManagedProcess/Server/Priority.hs | 115 +++++++++++++++++-
 tests/TestPrioritisedProcess.hs               |  85 ++++++++++++-
 5 files changed, 264 insertions(+), 42 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 455d59b..7e2cf37 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -605,13 +605,14 @@ module Control.Distributed.Process.ManagedProcess
   , newControlChan
   , channelControlPort
     -- * Prioritised mailboxes
-  , module Control.Distributed.Process.ManagedProcess.Server.Priority
+  , module P
   ) where
 
 import Control.Distributed.Process hiding (call, Message)
 import Control.Distributed.Process.ManagedProcess.Client
 import Control.Distributed.Process.ManagedProcess.Server
 import Control.Distributed.Process.ManagedProcess.Server.Priority
+import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P hiding (reject)
 import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
 import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Extras (ExitReason(..))
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 505e625..faefea9 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -37,6 +37,7 @@ import Control.Distributed.Process
   )
 import qualified Control.Distributed.Process as P
   ( liftIO
+  , say
   )
 import Control.Distributed.Process.Internal.Types
   ( Message(..)
@@ -113,13 +114,13 @@ type Limit = Maybe Int
 type Queue = PriorityQ Int Message
 
 data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
-                                   , sysTimeout  :: Timer
-                                   , usrTimeout  :: Delay
-                                   , internalQ   :: Queue
-                                   , procState   :: s
                                    , procDef     :: ProcessDefinition s
                                    , procPrio    :: [DispatchPriority s]
                                    , procFilters :: [DispatchFilter s]
+                                   , usrTimeout  :: Delay
+                                   , sysTimeout  :: Timer
+                                   , internalQ   :: Queue
+                                   , procState   :: s
                                    }
 type State s = IORef (ProcessState s)
 
@@ -305,8 +306,6 @@ precvLoop ppDef pState recvDelay = do
                                            , procFilters = filters    ppDef
                                            }
 
-  -- Rewrite this code when this is fixed:
-  -- https://ghc.haskell.org/trac/ghc/ticket/10149
   mask $ \restore -> do
     res <- catch (fmap Right $ restore $ runProcess st recvQueue)
                  (\(e :: SomeException) -> return $ Left e)
@@ -394,12 +393,12 @@ recvQueue = do
 
     processNext :: GenProcess s (ProcessAction s)
     processNext = do
-      (up, fs, ps) <- gets (liftA3 (,,) (unhandledMessagePolicy . procDef)
+      (up, pf, ps) <- gets (liftA3 (,,) (unhandledMessagePolicy . procDef)
                                          procFilters
                                          procState)
-      case fs of
+      case pf of
         [] -> consumeMessage
-        _  -> filterMessage  (filterNext up fs Nothing)
+        _  -> filterMessage  (filterNext up pf Nothing)
 
     consumeMessage = applyNext dequeue processApply
     filterMessage = applyNext peek
@@ -419,7 +418,7 @@ recvQueue = do
           setProcessState s'
           act' <- lift $ dynHandleFilter s' f msg
           filterNext mp' fs' act' msg
-      | Just (FilterReject s') <- act = do
+      | Just (FilterReject _ s') <- act = do
           setProcessState s' >> dequeue >>= lift . applyPolicy mp' s' . fromJust
       | Nothing <- act {- filter didn't apply to the input type -}
       , (f:fs') <- fs = processState >>= \s' -> do
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index d53e7e9..01b0279 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -6,6 +6,11 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LiberalTypeSynonyms        #-}
 {-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FunctionalDependencies     #-}
 
 -- | Types used throughout the ManagedProcess framework
 module Control.Distributed.Process.ManagedProcess.Internal.Types
@@ -37,6 +42,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , DispatchPriority(..)
   , DispatchFilter(..)
   , Filter(..)
+--   , Check(..)
   , PrioritisedProcessDefinition(..)
   , RecvTimeoutPolicy(..)
   , ControlChannel(..)
@@ -58,6 +64,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , CallRejected(..)
   , makeRef
   , caller
+  , rejectToCaller
   , recipient
   , tag
   , initCall
@@ -65,6 +72,7 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
+import Control.Arrow (Arrow, arr)
 import Control.Concurrent.STM (STM)
 import Control.Distributed.Process hiding (Message, finally)
 import Control.Monad.Catch (finally)
@@ -121,10 +129,15 @@ data Message a b =
   | ChanMessage a (SendPort b)
   deriving (Typeable, Generic)
 
-caller :: Message a b -> Maybe (CallRef b)
-caller (CallMessage _ ref) = Just ref
+caller :: forall a b . Message a b -> Maybe Recipient
+caller (CallMessage _ ref) = Just $ recipient ref
 caller _                   = Nothing
 
+rejectToCaller :: forall a b .
+                  Message a b -> String -> Process ()
+rejectToCaller (CallMessage _ ref) m = sendTo ref (CallRejected m (tag ref))
+rejectToCaller _                   _ = return ()
+
 instance (Serializable a, Serializable b) => Binary (Message a b) where
 instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where
   rnf (CastMessage a) = rnf a `seq` ()
@@ -196,6 +209,24 @@ data Condition s m =
   | State     (s -> Bool)       -- ^ predicated on the process state only
   | Input     (m -> Bool)       -- ^ predicated on the input message only
 
+{-
+
+class Check c s m | s m -> c where
+  -- data Checker c :: * -> * -> *
+  -- apply :: s -> m -> Checker c s m -> Bool
+  apply :: s -> m -> c -> Bool
+
+instance Check (Condition s m) s m where
+  -- data Checker (Condition s m) s m = CheckCond (Condition s m)
+  apply s m (Condition f) = f s m
+  apply s _ (State f)     = f s
+  apply _ m (Input f)     = f m
+
+instance Check (s -> m -> Bool) s m where
+   -- data Checker (s -> m -> Bool) s m = CheckF (s -> m -> Bool)
+   apply s m f = f s m
+-}
+
 -- | Informs a /shutdown handler/ of whether it is running due to a clean
 -- shutdown, or in response to an unhandled exception.
 data ExitState s = CleanShutdown s -- ^ given when an ordered shutdown is underway
@@ -298,30 +329,6 @@ data Dispatcher s =
     , dispatchIf :: s -> Message a b -> Bool
     }
 
-data Filter s = FilterOk s
-              | FilterReject s
-              | FilterSkip s
-
-data DispatchFilter s =
-    forall a b . (Serializable a, Serializable b) =>
-    FilterApi
-    {
-      apiFilter :: s -> Message a b -> Process (Filter s)
-    }
-  | forall a . (Serializable a) =>
-    FilterAny
-    {
-      anyFilter :: s -> a -> Process (Filter s)
-    }
-  | FilterRaw
-    {
-      rawFilter :: s -> P.Message -> Process (Maybe (Filter s))
-    }
-  | FilterState
-    {
-      stateFilter :: s -> Process (Maybe (Filter s))
-    }
-
 -- | Provides dispatch for channels and STM actions
 data ExternDispatcher s =
     forall a b . (Serializable a, Serializable b) =>
@@ -403,6 +410,30 @@ instance DynMessageHandler ExternDispatcher where
 instance DynMessageHandler DeferredDispatcher where
   dynHandleMessage _ s (DeferredDispatcher d) = d s
 
+data Filter s = FilterOk s
+              | forall m . (Show m) => FilterReject m s
+              | FilterSkip s
+
+data DispatchFilter s =
+    forall a b . (Serializable a, Serializable b) =>
+    FilterApi
+    {
+      apiFilter :: s -> Message a b -> Process (Filter s)
+    }
+  | forall a . (Serializable a) =>
+    FilterAny
+    {
+      anyFilter :: s -> a -> Process (Filter s)
+    }
+  | FilterRaw
+    {
+      rawFilter :: s -> P.Message -> Process (Maybe (Filter s))
+    }
+  | FilterState
+    {
+      stateFilter :: s -> Process (Maybe (Filter s))
+    }
+
 -- | Maps filters to an action that can take place outside of a
 -- expect/recieve block.
 class DynFilterHandler d where
@@ -468,6 +499,7 @@ data UnhandledMessagePolicy =
   | DeadLetter ProcessId -- ^ forward the message to the given recipient
   | Log                  -- ^ log messages, then behave identically to @Drop@
   | Drop                 -- ^ dequeue and then drop/ignore the message
+  deriving (Show, Eq)
 
 -- | Stores the functions that determine runtime behaviour in response to
 -- incoming messages and a policy for responding to unhandled messages.
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index edf1bb0..7b7509b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE PatternGuards              #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -15,13 +18,27 @@
 -- The Prioritised Server portion of the /Managed Process/ API.
 -----------------------------------------------------------------------------
 module Control.Distributed.Process.ManagedProcess.Server.Priority
-  ( prioritiseCall
+  ( -- * Prioritising API Handlers
+    prioritiseCall
   , prioritiseCall_
   , prioritiseCast
   , prioritiseCast_
   , prioritiseInfo
   , prioritiseInfo_
   , setPriority
+    -- * Creating Filters
+  , check
+  , raw
+  , api
+  , api_
+  , message
+  , refuse
+  , reject
+  , rejectApi
+  , store
+  , Filter()
+  , DispatchFilter()
+  , Message()
   ) where
 
 import Control.Distributed.Process hiding (call, Message)
@@ -30,6 +47,102 @@ import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Serializable
 import Prelude hiding (init)
 
+data RejectedByServer = RejectedByServer deriving (Show)
+
+data FilterHandler s =
+    forall m . (Serializable m) =>
+    HandlePure
+    {
+      pureCheck :: s -> m -> Process Bool
+    , handler :: s -> m -> Process (Filter s)
+    }
+  | forall m b . (Serializable m, Serializable b) =>
+    HandleApi
+    {
+      apiCheck :: s -> m -> Process Bool
+    , apiHandler :: s -> Message m b -> Process (Filter s)
+    }
+  | HandleRaw
+    {
+      rawCheck :: s -> P.Message -> Process Bool
+    , rawHandler :: s -> P.Message -> Process (Maybe (Filter s))
+    }
+  | HandleState { stateHandler :: s -> Process (Maybe (Filter s)) }
+
+{-
+check :: forall c s m . (Check c s m)
+      => c -> (s -> Process (Filter s)) -> s -> m -> Process (Filter s)
+-}
+check :: forall s . FilterHandler s -> DispatchFilter s
+check h
+  | HandlePure{..}  <- h = FilterAny $ \s m -> pureCheck s m >>= procUnless s m handler
+  | HandleRaw{..}   <- h = FilterRaw $ \s m -> do
+      c <- rawCheck s m
+      if c then return $ Just $ FilterOk s
+           else rawHandler s m
+  | HandleState{..} <- h = FilterState stateHandler
+  | HandleApi{..}   <- h = FilterApi $ \s m@(CallMessage m' _) -> do
+      c <- apiCheck s m'
+      if c then return $ FilterOk s
+           else apiHandler s m
+
+  where
+    procUnless s _ _ True  = return $ FilterOk s
+    procUnless s m h' False = h' s m
+
+raw :: forall s .
+       (s -> P.Message -> Process Bool)
+    -> (s -> P.Message -> Process (Maybe (Filter s)))
+    -> FilterHandler s
+raw = HandleRaw
+
+api :: forall s m b . (Serializable m, Serializable b)
+    => (s -> m -> Process Bool)
+    -> (s -> Message m b -> Process (Filter s))
+    -> FilterHandler s
+api = HandleApi
+
+api_ :: forall m b s . (Serializable m, Serializable b)
+     => (m -> Process Bool)
+     -> (s -> Message m b -> Process (Filter s))
+     -> FilterHandler s
+api_ c h = api (const $ c) h
+
+message :: forall s m . (Serializable m)
+        => (s -> m -> Process Bool)
+        -> (s -> m -> Process (Filter s))
+        -> FilterHandler s
+message = HandlePure
+
+reject :: forall s m r . (Show r)
+       => r -> s -> m -> Process (Filter s)
+reject r = \s _ -> do return $ FilterReject (show r) s
+
+rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b)
+          => r -> s -> Message m b -> Process (Filter s)
+rejectApi r = \s m -> do let r' = show r
+                         rejectToCaller m r'
+                         return $ FilterSkip s
+
+store :: (s -> s) -> DispatchFilter s
+store f = FilterState $ return . Just . FilterOk . f
+
+refuse :: forall s m . (Serializable m)
+       => (m -> Bool)
+       -> DispatchFilter s
+refuse c = check $ message (const $ \m -> return $ c m) (reject RejectedByServer)
+
+{-
+
+apiCheck :: forall s m r . (Serializable m, Serializable r)
+      => (s -> Message m r -> Bool)
+      -> (s -> Message m r -> Process (Filter s))
+      -> DispatchFilter s
+apiCheck c h = checkM (\s m -> return $ c s m) h
+
+apiReject
+-}
+
 -- | Sets an explicit priority
 setPriority :: Int -> Priority m
 setPriority = Priority
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 490a107..5c29fc0 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -4,6 +4,7 @@
 
 module Main where
 
+import Control.Applicative
 import Control.Concurrent.MVar
 import Control.Concurrent.STM.TQueue
  ( newTQueueIO
@@ -14,17 +15,21 @@ import Control.Exception (SomeException)
 import Control.DeepSeq (NFData)
 import Control.Distributed.Process hiding (call, send, catch, sendChan)
 import Control.Distributed.Process.Node
-import Control.Distributed.Process.Extras hiding (__remoteTable)
-import Control.Distributed.Process.Async
-import Control.Distributed.Process.ManagedProcess
+import Control.Distributed.Process.Extras hiding (__remoteTable, monitor)
+import Control.Distributed.Process.Async hiding (check)
+import Control.Distributed.Process.ManagedProcess hiding (reject)
+import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P (Message)
+import Control.Distributed.Process.ManagedProcess.Server.Priority (reject)
 import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer
 import Control.Distributed.Process.Serializable()
+import Control.Monad
 import Control.Monad.Catch (catch)
 
 import Data.Binary
 import Data.Either (rights)
+import Data.List (isInfixOf)
 import Data.Typeable (Typeable)
 
 #if ! MIN_VERSION_base(4,6,0)
@@ -194,6 +199,75 @@ launchStmOverloadServer = do
   pid <- spawnLocal $ pserve () (statelessInit Infinity) p
   return (pid, cp)
 
+data Foo = Foo deriving (Show)
+
+launchFilteredServer :: ProcessId -> Process (ProcessId, ControlPort (SendPort Int))
+launchFilteredServer us = do
+  cc <- newControlChan :: Process (ControlChannel (SendPort Int))
+  let cp = channelControlPort cc
+
+  let procDef = defaultProcess {
+                  externHandlers = [
+                    handleControlChan cc (\s (p :: SendPort Int) -> sendChan p s >> continue s)
+                  ]
+                , apiHandlers = [
+                    handleCast (\s sp -> sendChan sp () >> continue s)
+                  , handleCall_ (\(s :: String) -> return s)
+                  ]
+                , unhandledMessagePolicy = DeadLetter us
+                } :: ProcessDefinition Int
+
+  let p = procDef `prioritised` ([
+               prioritiseCast_ (\() -> setPriority 1 :: Priority ())
+             , prioritiseCall_ (\(_ :: String) -> setPriority 100 :: Priority String)
+             ] :: [DispatchPriority Int]
+          ) :: PrioritisedProcessDefinition Int
+
+  let rejectUnchecked =
+        rejectApi Foo :: Int -> P.Message String String -> Process (Filter Int)
+
+  let p' = p {
+    filters = [
+      store $ (+1)
+    , check $ api_ (\(s :: String) -> return $ "checked-" `isInfixOf` s) rejectUnchecked
+    , check $ message (\_ m@(_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo
+    , refuse ((> 10) :: Int -> Bool)
+    ]
+  }
+
+  pid <- spawnLocal $ pserve 0 (\c -> return $ InitOk c Infinity) p'
+  return (pid, cp)
+
+testFilteringBehavior :: TestResult Bool -> Process ()
+testFilteringBehavior result = do
+  us <- getSelfPid
+  (sp, rp) <- newChan
+  (pid, cp) <- launchFilteredServer us
+  mRef <- monitor pid
+
+  sendControlMessage cp sp
+
+  r <- receiveChan rp :: Process Int
+  when (r > 1) $ stash result False >> die "we're done..."
+
+  Left res <- safeCall pid "bad-input" :: Process (Either ExitReason String)
+
+  send pid (mRef, us)  -- server doesn't like this, dead letters it...
+  -- back to us
+  mrp <- receiveWait [ matchIf (\(m, p) -> m == mRef && p == us) return ]
+
+  sendControlMessage cp sp
+
+  r2 <- receiveChan rp :: Process Int
+  when (r2 < 3) $ stash result False >> die "we're done again..."
+
+  -- server also doesn't like this, and sends it right back (via \DeadLetter us/)
+  send pid (25 :: Int)
+
+  m <- receiveWait [ matchIf (== 25) return ] :: Process Int
+  stash result True
+  kill pid "done"
+
 testExternalTimedOverflowHandling :: TestResult Bool -> Process ()
 testExternalTimedOverflowHandling result = do
   (pid, cp) <- launchStmOverloadServer -- default 10k mailbox drain limit
@@ -336,7 +410,7 @@ tests transport = do
              localNode True (testKillMidCall $ wrap server))
           , testCase "server rejects call"
              (delayedAssertion "expected server to send CallRejected"
-              localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server))             
+              localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server))
           , testCase "simple exit handling"
             (delayedAssertion "expected handler to catch exception and continue"
              localNode Nothing (testSimpleErrorHandling $ explodingServer))
@@ -366,6 +440,9 @@ tests transport = do
           , testCase "Timeout-Based Overload Management with Control Channels"
             (delayedAssertion "expected the server loop to reply"
              localNode True testExternalTimedOverflowHandling)
+          , testCase "Complex pre/before filters"
+             (delayedAssertion "expected verifiable filter actions"
+              localNode True testFilteringBehavior)
          ]
       ]
 

From bd3508d5fe04d134b782e6eb76e933d3816f5087 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 6 Mar 2017 14:34:00 +0000
Subject: [PATCH 46/50] additional filter expression

---
 .../ManagedProcess/Internal/GenProcess.hs     | 81 ++++++++++++-----
 .../Process/ManagedProcess/Internal/Types.hs  | 90 ++++++-------------
 .../Process/ManagedProcess/Server.hs          | 10 +--
 .../Process/ManagedProcess/Server/Priority.hs | 49 +++++++++-
 tests/ManagedProcessCommon.hs                 |  2 +-
 tests/TestPrioritisedProcess.hs               | 14 +--
 6 files changed, 143 insertions(+), 103 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index faefea9..ccb9661 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -14,19 +14,28 @@
 module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   ( recvLoop
   , precvLoop
-  , getState
   , currentTimeout
   , systemTimeout
   , drainTimeout
-  , resetTimer
+  , processState
+  , processDefinition
+  , processFilters
+  , processUnhandledMsgPolicy
+  , gets
+  , getAndModifyState
+  , modifyState
+  , setUserTimeout
+  , setProcessState
   , GenProcess
   ) where
 
-import Control.Applicative (liftA3)
+import Control.Applicative (liftA2  )
 import Control.Distributed.Process
   ( match
   , matchAny
   , matchMessage
+  , handleMessage
+  , handleMessageIf
   , receiveTimeout
   , receiveWait
   , forward
@@ -37,7 +46,6 @@ import Control.Distributed.Process
   )
 import qualified Control.Distributed.Process as P
   ( liftIO
-  , say
   )
 import Control.Distributed.Process.Internal.Types
   ( Message(..)
@@ -54,7 +62,6 @@ import Control.Distributed.Process.ManagedProcess.Timer
   , delayTimer
   , startTimer
   , stopTimer
-  , resetTimer
   , matchTimeout
   , TimedOut(..)
   )
@@ -178,11 +185,6 @@ lift p = GenProcess $ ST.lift p
 liftIO :: IO a -> GenProcess s a
 liftIO = lift . P.liftIO
 
--- | Get the current process state
-getState :: forall s . GenProcess s (ProcessState s)
-getState = ST.get >>= \(s :: State s) -> liftIO $ do
-  atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', s')
-
 gets :: forall s a . (ProcessState s -> a) -> GenProcess s a
 gets f = ST.get >>= \(s :: State s) -> liftIO $ do
   atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', f s' :: a)
@@ -279,6 +281,40 @@ enqueueMessage s (p:ps) m' = let checkPrio = prioritise p s in do
 -- Process Loop Implementations                                               --
 --------------------------------------------------------------------------------
 
+-- | Maps handlers to a dynamic action that can take place outside of a
+-- expect/recieve block. This is used by the prioritised process loop.
+class DynMessageHandler d where
+  dynHandleMessage :: UnhandledMessagePolicy
+                   -> s
+                   -> d s
+                   -> Message
+                   -> Process (Maybe (ProcessAction s))
+
+instance DynMessageHandler Dispatcher where
+  dynHandleMessage _ s (Dispatch   d)   msg = handleMessage msg (d s)
+  dynHandleMessage _ s (DispatchIf d c) msg = handleMessageIf msg (c s) (d s)
+
+instance DynMessageHandler ExternDispatcher where
+  dynHandleMessage _ s (DispatchCC  _ d)     msg = handleMessage msg (d s)
+  dynHandleMessage _ s (DispatchSTM _ d _ _) msg = handleMessage msg (d s)
+
+instance DynMessageHandler DeferredDispatcher where
+  dynHandleMessage _ s (DeferredDispatcher d) = d s
+
+-- | Maps filters to an action that can take place outside of a
+-- expect/recieve block.
+class DynFilterHandler d where
+  dynHandleFilter :: s
+                  -> d s
+                  -> Message
+                  -> Process (Maybe (Filter s))
+
+instance DynFilterHandler DispatchFilter where
+  dynHandleFilter s (FilterApi d)   msg = handleMessage msg (d s)
+  dynHandleFilter s (FilterAny d)   msg = handleMessage msg (d s)
+  dynHandleFilter s (FilterRaw d)   msg = d s msg
+  dynHandleFilter s (FilterState d) _   = d s
+
 -- | Prioritised process loop.
 --
 -- Evaluating this function will cause the caller to enter a server loop,
@@ -303,8 +339,8 @@ precvLoop ppDef pState recvDelay = do
                                            , procState   = pState
                                            , procDef     = processDef ppDef
                                            , procPrio    = priorities ppDef
-                                           , procFilters = filters    ppDef
-                                           }
+                                           , procFilters = filters ppDef
+                                          }
 
   mask $ \restore -> do
     res <- catch (fmap Right $ restore $ runProcess st recvQueue)
@@ -393,9 +429,7 @@ recvQueue = do
 
     processNext :: GenProcess s (ProcessAction s)
     processNext = do
-      (up, pf, ps) <- gets (liftA3 (,,) (unhandledMessagePolicy . procDef)
-                                         procFilters
-                                         procState)
+      (up, pf) <- gets $ liftA2 (,) (unhandledMessagePolicy . procDef) procFilters
       case pf of
         [] -> consumeMessage
         _  -> filterMessage  (filterNext up pf Nothing)
@@ -409,12 +443,13 @@ recvQueue = do
                -> Message
                -> GenProcess s (ProcessAction s)
     filterNext mp' fs act msg
-      | Just (FilterSkip s') <- act = {- state!!!!! -} dequeue >> return ProcessSkip
-      | Just (FilterOk s')   <- act
-      , []                   <- fs = setProcessState s' >> applyNext dequeue processApply
-      | Nothing <- act, []   <- fs = applyNext dequeue processApply
-      | Just (FilterOk s')   <- act
-      , (f:fs')              <- fs = do
+      | Just (FilterSkip s')   <- act = setProcessState s' >> dequeue >> return ProcessSkip
+      | Just (FilterStop s' r) <- act = return $ ProcessStopping s' r
+      | Just (FilterOk s')     <- act
+      , []                     <- fs = setProcessState s' >> applyNext dequeue processApply
+      | Nothing <- act, []     <- fs = applyNext dequeue processApply
+      | Just (FilterOk s')     <- act
+      , (f:fs')                <- fs = do
           setProcessState s'
           act' <- lift $ dynHandleFilter s' f msg
           filterNext mp' fs' act' msg
@@ -434,8 +469,8 @@ recvQueue = do
         Just msg -> handler msg
 
     processApply msg = do
-      def <- processDefinition
-      pState <- processState
+      (def, pState) <- gets $ liftA2 (,) procDef procState
+
       let pol          = unhandledMessagePolicy def
           apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)
           infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 01b0279..f8b45ef 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -55,8 +55,6 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , ExitSignalDispatcher(..)
   , MessageMatcher(..)
   , ExternMatcher(..)
-  , DynMessageHandler(..)
-  , DynFilterHandler(..)
   , Message(..)
   , CallResponse(..)
   , CallId
@@ -72,7 +70,6 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   , waitResponse
   ) where
 
-import Control.Arrow (Arrow, arr)
 import Control.Concurrent.STM (STM)
 import Control.Distributed.Process hiding (Message, finally)
 import Control.Monad.Catch (finally)
@@ -315,6 +312,31 @@ channelControlPort :: ControlChannel m
                    -> ControlPort m
 channelControlPort cc = ControlPort $ fst $ unControl cc
 
+data Filter s = FilterOk s
+              | forall m . (Show m) => FilterReject m s
+              | FilterSkip s
+              | FilterStop s ExitReason
+
+data DispatchFilter s =
+    forall a b . (Serializable a, Serializable b) =>
+    FilterApi
+    {
+      apiFilter :: s -> Message a b -> Process (Filter s)
+    }
+  | forall a . (Serializable a) =>
+    FilterAny
+    {
+      anyFilter :: s -> a -> Process (Filter s)
+    }
+  | FilterRaw
+    {
+      rawFilter :: s -> P.Message -> Process (Maybe (Filter s))
+    }
+  | FilterState
+    {
+      stateFilter :: s -> Process (Maybe (Filter s))
+    }
+
 -- | Provides dispatch from cast and call messages to a typed handler.
 data Dispatcher s =
     forall a b . (Serializable a, Serializable b) =>
@@ -370,8 +392,8 @@ class MessageMatcher d where
   matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)
 
 instance MessageMatcher Dispatcher where
-  matchDispatch _ s (Dispatch    d)      = match   (d s)
-  matchDispatch _ s (DispatchIf  d cond) = matchIf (cond s) (d s)
+  matchDispatch _ s (Dispatch         d)      = match   (d s)
+  matchDispatch _ s (DispatchIf       d cond) = matchIf (cond s) (d s)
 
 instance MessageMatcher ExternDispatcher where
   matchDispatch _ s (DispatchCC  c d)     = matchChan c (d s)
@@ -390,64 +412,6 @@ instance ExternMatcher ExternDispatcher where
   matchMapExtern _ _ f (DispatchCC c _)      = matchChan c (return . f . unsafeWrapMessage)
   matchMapExtern _ _ f (DispatchSTM _ _ _ p) = p f
 
--- | Maps handlers to a dynamic action that can take place outside of a
--- expect/recieve block.
-class DynMessageHandler d where
-  dynHandleMessage :: UnhandledMessagePolicy
-                   -> s
-                   -> d s
-                   -> P.Message
-                   -> Process (Maybe (ProcessAction s))
-
-instance DynMessageHandler Dispatcher where
-  dynHandleMessage _ s (Dispatch       d)   msg = handleMessage   msg (d s)
-  dynHandleMessage _ s (DispatchIf     d c) msg = handleMessageIf msg (c s) (d s)
-
-instance DynMessageHandler ExternDispatcher where
-  dynHandleMessage _ s (DispatchCC  _ d)     msg = handleMessage msg (d s)
-  dynHandleMessage _ s (DispatchSTM _ d _ _) msg = handleMessage msg (d s)
-
-instance DynMessageHandler DeferredDispatcher where
-  dynHandleMessage _ s (DeferredDispatcher d) = d s
-
-data Filter s = FilterOk s
-              | forall m . (Show m) => FilterReject m s
-              | FilterSkip s
-
-data DispatchFilter s =
-    forall a b . (Serializable a, Serializable b) =>
-    FilterApi
-    {
-      apiFilter :: s -> Message a b -> Process (Filter s)
-    }
-  | forall a . (Serializable a) =>
-    FilterAny
-    {
-      anyFilter :: s -> a -> Process (Filter s)
-    }
-  | FilterRaw
-    {
-      rawFilter :: s -> P.Message -> Process (Maybe (Filter s))
-    }
-  | FilterState
-    {
-      stateFilter :: s -> Process (Maybe (Filter s))
-    }
-
--- | Maps filters to an action that can take place outside of a
--- expect/recieve block.
-class DynFilterHandler d where
-  dynHandleFilter :: s
-                  -> d s
-                  -> P.Message
-                  -> Process (Maybe (Filter s))
-
-instance DynFilterHandler DispatchFilter where
-  dynHandleFilter s (FilterApi d)   msg = handleMessage msg (d s)
-  dynHandleFilter s (FilterAny d)   msg = handleMessage msg (d s)
-  dynHandleFilter s (FilterRaw d)   msg = d s msg
-  dynHandleFilter s (FilterState d) _   = d s
-
 -- | Priority of a message, encoded as an @Int@
 newtype Priority a = Priority { getPrio :: Int }
 
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 518a985..4a08900 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -81,10 +81,8 @@ import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
   , Routable(..)
-  , Resolvable(..)
   )
 import Control.Distributed.Process.Extras.Time
-import Data.Maybe (fromJust)
 import Prelude hiding (init)
 
 --------------------------------------------------------------------------------
@@ -617,10 +615,10 @@ mkReply :: (Serializable b)
         -> Process (ProcessAction s)
 mkReply cRef act
   | (NoReply a)          <- act  = return a
-  | (CallRef (_, tag))   <- cRef
-  , (ProcessReply  r' a) <- act  = sendTo cRef (CallResponse r' tag) >> return a
-  | (CallRef (_, tag))   <- cRef
-  , (ProcessReject r' a) <- act  = sendTo cRef (CallRejected r' tag) >> return a
+  | (CallRef (_, tg'))   <- cRef
+  , (ProcessReply  r' a) <- act  = sendTo cRef (CallResponse r' tg') >> return a
+  | (CallRef (_, ct'))   <- cRef
+  , (ProcessReject r' a) <- act  = sendTo cRef (CallRejected r' ct') >> return a
   | otherwise                    = die $ ExitOther "mkReply.InvalidState"
 
 -- these functions are the inverse of 'condition', 'state' and 'input'
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index 7b7509b..6babe5b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -29,13 +29,18 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
     -- * Creating Filters
   , check
   , raw
+  , raw_
   , api
   , api_
-  , message
+  , info
+  , info_
   , refuse
   , reject
   , rejectApi
   , store
+  , crash
+  , ensure
+  , ensureM
   , Filter()
   , DispatchFilter()
   , Message()
@@ -43,6 +48,9 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
 
 import Control.Distributed.Process hiding (call, Message)
 import qualified Control.Distributed.Process as P (Message)
+import Control.Distributed.Process.Extras
+  ( ExitReason(..)
+  )
 import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.Serializable
 import Prelude hiding (init)
@@ -96,6 +104,12 @@ raw :: forall s .
     -> FilterHandler s
 raw = HandleRaw
 
+raw_ :: forall s .
+        (P.Message -> Process Bool)
+     -> (s -> P.Message -> Process (Maybe (Filter s)))
+     -> FilterHandler s
+raw_ c h = raw (const $ c) h
+
 api :: forall s m b . (Serializable m, Serializable b)
     => (s -> m -> Process Bool)
     -> (s -> Message m b -> Process (Filter s))
@@ -108,16 +122,25 @@ api_ :: forall m b s . (Serializable m, Serializable b)
      -> FilterHandler s
 api_ c h = api (const $ c) h
 
-message :: forall s m . (Serializable m)
+info :: forall s m . (Serializable m)
         => (s -> m -> Process Bool)
         -> (s -> m -> Process (Filter s))
         -> FilterHandler s
-message = HandlePure
+info = HandlePure
+
+info_ :: forall s m . (Serializable m)
+        => (m -> Process Bool)
+        -> (s -> m -> Process (Filter s))
+        -> FilterHandler s
+info_ c h = info (const $ c) h
 
 reject :: forall s m r . (Show r)
        => r -> s -> m -> Process (Filter s)
 reject r = \s _ -> do return $ FilterReject (show r) s
 
+crash :: forall s . s -> ExitReason -> Process (Filter s)
+crash s r = return $ FilterStop s r
+
 rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b)
           => r -> s -> Message m b -> Process (Filter s)
 rejectApi r = \s m -> do let r' = show r
@@ -130,7 +153,7 @@ store f = FilterState $ return . Just . FilterOk . f
 refuse :: forall s m . (Serializable m)
        => (m -> Bool)
        -> DispatchFilter s
-refuse c = check $ message (const $ \m -> return $ c m) (reject RejectedByServer)
+refuse c = check $ info (const $ \m -> return $ c m) (reject RejectedByServer)
 
 {-
 
@@ -143,6 +166,24 @@ apiCheck c h = checkM (\s m -> return $ c s m) h
 apiReject
 -}
 
+ensure :: forall s . (s -> Bool) -> DispatchFilter s
+ensure c =
+  check $ HandleState { stateHandler = (\s -> if c s
+                                                then return $ Just $ FilterOk s
+                                                else return $ Just $ FilterStop s filterFail)
+                      }
+
+ensureM :: forall s m . (Serializable m) => (s -> m -> Process Bool) -> DispatchFilter s
+ensureM c =
+  check $ HandlePure { pureCheck = c
+                     , handler = (\s _ -> return $ FilterStop s filterFail) :: s -> m -> Process (Filter s)
+                     }
+
+-- TODO: add the type rep for a more descriptive failure message
+
+filterFail :: ExitReason
+filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed"
+
 -- | Sets an explicit priority
 setPriority :: Int -> Priority m
 setPriority = Priority
diff --git a/tests/ManagedProcessCommon.hs b/tests/ManagedProcessCommon.hs
index 84f0baf..5ab2059 100644
--- a/tests/ManagedProcessCommon.hs
+++ b/tests/ManagedProcessCommon.hs
@@ -304,7 +304,7 @@ testSimpleErrorHandling launch result = do
   -- this should be *altered* because of the exit handler
   Nothing <- callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String)
 
-  Right s <- awaitResponse pid [
+  Right _ <- awaitResponse pid [
       matchIf (\(s :: String) -> s == "foobar")
               (\s -> return (Right s) :: Process (Either ExitReason String))
     ]
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 5c29fc0..d5174ed 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -4,7 +4,6 @@
 
 module Main where
 
-import Control.Applicative
 import Control.Concurrent.MVar
 import Control.Concurrent.STM.TQueue
  ( newTQueueIO
@@ -213,6 +212,7 @@ launchFilteredServer us = do
                 , apiHandlers = [
                     handleCast (\s sp -> sendChan sp () >> continue s)
                   , handleCall_ (\(s :: String) -> return s)
+                  , handleCall_ (\(i :: Int) -> return i)
                   ]
                 , unhandledMessagePolicy = DeadLetter us
                 } :: ProcessDefinition Int
@@ -228,9 +228,11 @@ launchFilteredServer us = do
 
   let p' = p {
     filters = [
-      store $ (+1)
+      store  (+1)
+    , ensure (>0)  -- a bit pointless, but we're just checking the API
+
     , check $ api_ (\(s :: String) -> return $ "checked-" `isInfixOf` s) rejectUnchecked
-    , check $ message (\_ m@(_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo
+    , check $ info (\_ (_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo
     , refuse ((> 10) :: Int -> Bool)
     ]
   }
@@ -250,11 +252,11 @@ testFilteringBehavior result = do
   r <- receiveChan rp :: Process Int
   when (r > 1) $ stash result False >> die "we're done..."
 
-  Left res <- safeCall pid "bad-input" :: Process (Either ExitReason String)
+  Left _ <- safeCall pid "bad-input" :: Process (Either ExitReason String)
 
   send pid (mRef, us)  -- server doesn't like this, dead letters it...
   -- back to us
-  mrp <- receiveWait [ matchIf (\(m, p) -> m == mRef && p == us) return ]
+  void $ receiveWait [ matchIf (\(m, p) -> m == mRef && p == us) return ]
 
   sendControlMessage cp sp
 
@@ -265,7 +267,7 @@ testFilteringBehavior result = do
   send pid (25 :: Int)
 
   m <- receiveWait [ matchIf (== 25) return ] :: Process Int
-  stash result True
+  stash result $ m == 25
   kill pid "done"
 
 testExternalTimedOverflowHandling :: TestResult Bool -> Process ()

From 325de32d2eb0faecf7e19d015a8ed1ef8e3e9c92 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 6 Mar 2017 15:20:16 +0000
Subject: [PATCH 47/50] Timer docs!

---
 src/Control/Distributed/Process/ManagedProcess.hs     |  1 -
 .../Process/ManagedProcess/Internal/GenProcess.hs     |  6 +++++-
 .../Distributed/Process/ManagedProcess/Timer.hs       | 11 +++++++++++
 tests/TestPrioritisedProcess.hs                       |  2 +-
 4 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 7e2cf37..167b4d5 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -611,7 +611,6 @@ module Control.Distributed.Process.ManagedProcess
 import Control.Distributed.Process hiding (call, Message)
 import Control.Distributed.Process.ManagedProcess.Client
 import Control.Distributed.Process.ManagedProcess.Server
-import Control.Distributed.Process.ManagedProcess.Server.Priority
 import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P hiding (reject)
 import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
 import Control.Distributed.Process.ManagedProcess.Internal.Types
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index ccb9661..e50b7a2 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -40,6 +40,7 @@ import Control.Distributed.Process
   , receiveWait
   , forward
   , catchesExit
+  , catchExit
   , Process
   , ProcessId
   , Match
@@ -343,7 +344,7 @@ precvLoop ppDef pState recvDelay = do
                                           }
 
   mask $ \restore -> do
-    res <- catch (fmap Right $ restore $ runProcess st recvQueue)
+    res <- catch (fmap Right $ restore $ loop st)
                  (\(e :: SomeException) -> return $ Left e)
 
     -- res could be (Left ex), so we restore process state & def from our IORef
@@ -359,6 +360,9 @@ precvLoop ppDef pState recvDelay = do
         -- we'll attempt to run the exit handler with the original state
         restore $ sh (LastKnown st') (ExitOther $ show ex)
         throwM ex
+  where
+    loop st' = catchExit (runProcess st' recvQueue)
+                         (\_ (r :: ExitReason) -> return (r, st'))
 
 recvQueue :: GenProcess s ExitReason
 recvQueue = do
diff --git a/src/Control/Distributed/Process/ManagedProcess/Timer.hs b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
index 19b22ca..ab80b1e 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Timer.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
@@ -85,15 +85,19 @@ data Timer = Timer { timerDelay  :: Delay
                    , mtSignal :: Maybe (TVar Bool)
                    }
 
+-- | @True@ if a @Timer@ is currently active.
 isActive :: Timer -> Bool
 isActive = isJust . mtSignal
 
+-- | Creates a default @Timer@ which is inactive.
 delayTimer :: Delay -> Timer
 delayTimer d = Timer d noPid noTVar
   where
     noPid  = Nothing :: Maybe ProcessId
     noTVar = Nothing :: Maybe (TVar Bool)
 
+-- | Starts a @Timer@
+-- Will use the GHC @registerDelay@ API if @rtsSupportsBoundThreads == True@
 startTimer :: Delay -> Process Timer
 startTimer d
   | Delay t <- d = establishTimer t
@@ -116,6 +120,7 @@ startTimer d
                        , mtSignal = Just tSig
                        }
 
+-- | Stops a previously started @Timer@. Has no effect if the @Timer@ is inactive.
 stopTimer :: Timer -> Process Timer
 stopTimer t@Timer{..} = do
   clearTimer mtPidRef
@@ -123,20 +128,26 @@ stopTimer t@Timer{..} = do
            , mtSignal = Nothing
            }
 
+-- | Clears and restarts a @Timer@.
 resetTimer :: Timer -> Delay -> Process Timer
 resetTimer Timer{..} d = clearTimer mtPidRef >> startTimer d
 
+-- | Clears/cancels a running timer. Has no effect if the @Timer@ is inactive.
 clearTimer :: Maybe TimerRef -> Process ()
 clearTimer ref
   | isJust ref = cancelTimer (fromJust ref)
   | otherwise  = return ()
 
+-- | Creates a @Match@ for a given timer, for use with Cloud Haskell's messaging
+-- primitives for selective receives.
 matchTimeout :: Timer -> [Match (Either TimedOut Message)]
 matchTimeout t@Timer{..}
     | isActive t = [ matchSTM (readTimer $ fromJust mtSignal)
                               (return . Left) ]
     | otherwise  = []
 
+-- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the
+-- variable is set to true. Will @retry@ in the meanwhile.
 readTimer :: TVar Bool -> STM TimedOut
 readTimer t = do
    expired <- readTVar t
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index d5174ed..9af0eca 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -18,7 +18,7 @@ import Control.Distributed.Process.Extras hiding (__remoteTable, monitor)
 import Control.Distributed.Process.Async hiding (check)
 import Control.Distributed.Process.ManagedProcess hiding (reject)
 import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P (Message)
-import Control.Distributed.Process.ManagedProcess.Server.Priority (reject)
+import Control.Distributed.Process.ManagedProcess.Server.Priority
 import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Extras.Timer

From 9486fd00b3849623edfb388fa95bcad32dff037b Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Sat, 11 Mar 2017 02:39:40 +0000
Subject: [PATCH 48/50] Initial support for internal timers

---
 .../Distributed/Process/ManagedProcess.hs     |   2 +-
 .../Process/ManagedProcess/Client.hs          |   2 +-
 .../ManagedProcess/Internal/GenProcess.hs     | 183 ++++++++----------
 .../Process/ManagedProcess/Internal/Types.hs  | 119 +++++++++++-
 .../Process/ManagedProcess/Server.hs          |   2 +-
 .../Process/ManagedProcess/Server/Priority.hs |  23 ++-
 .../ManagedProcess/Server/Restricted.hs       |   2 +-
 .../Process/ManagedProcess/Timer.hs           |  38 +++-
 tests/TestPrioritisedProcess.hs               |  32 ++-
 9 files changed, 285 insertions(+), 118 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess.hs b/src/Control/Distributed/Process/ManagedProcess.hs
index 167b4d5..111459a 100644
--- a/src/Control/Distributed/Process/ManagedProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess.hs
@@ -613,7 +613,7 @@ import Control.Distributed.Process.ManagedProcess.Client
 import Control.Distributed.Process.ManagedProcess.Server
 import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P hiding (reject)
 import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
-import Control.Distributed.Process.ManagedProcess.Internal.Types
+import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (runProcess)
 import Control.Distributed.Process.Extras (ExitReason(..))
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Serializable
diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 784934e..5972f32 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -35,7 +35,7 @@ import Control.Concurrent.STM (atomically, STM)
 import Control.Distributed.Process hiding (call, finally)
 import Control.Distributed.Process.Serializable
 import Control.Distributed.Process.Async hiding (check)
-import Control.Distributed.Process.ManagedProcess.Internal.Types
+import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO)
 import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as T
 import Control.Distributed.Process.Extras.Internal.Types (resolveOrDie)
 import Control.Distributed.Process.Extras hiding (monitor, sendChan)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index e50b7a2..015377b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -27,9 +27,12 @@ module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   , setUserTimeout
   , setProcessState
   , GenProcess
+  , peek
+  , push
+  , addUserTimer
   ) where
 
-import Control.Applicative (liftA2  )
+import Control.Applicative (liftA2)
 import Control.Distributed.Process
   ( match
   , matchAny
@@ -41,6 +44,7 @@ import Control.Distributed.Process
   , forward
   , catchesExit
   , catchExit
+  , die
   , Process
   , ProcessId
   , Match
@@ -60,16 +64,16 @@ import Control.Distributed.Process.ManagedProcess.Server
   )
 import Control.Distributed.Process.ManagedProcess.Timer
   ( Timer(timerDelay)
+  , TimerKey
+  , TimedOut(..)
   , delayTimer
   , startTimer
   , stopTimer
   , matchTimeout
-  , TimedOut(..)
+  , matchKey
+  , matchRun
   )
 import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (Message)
-import Control.Distributed.Process.Extras.Internal.Queue.PriorityQ
-  ( PriorityQ
-  )
 import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as Q
   ( empty
   , dequeue
@@ -83,109 +87,31 @@ import Control.Distributed.Process.Extras
 import qualified Control.Distributed.Process.Extras.SystemLog as Log
 import Control.Distributed.Process.Extras.Time
 import Control.Monad (void)
-import Control.Monad.Fix (MonadFix)
 import Control.Monad.Catch
   ( mask_
   , catch
   , throwM
-  , uninterruptibleMask
   , mask
   , SomeException
-  , MonadThrow
-  , MonadCatch
-  , MonadMask
-  )
-import qualified Control.Monad.Catch as Catch
-  ( catch
-  , throwM
   )
-import Control.Monad.IO.Class (MonadIO)
 import qualified Control.Monad.State.Strict as ST
-  ( MonadState
-  , StateT
-  , get
-  , lift
-  , runStateT
+  ( get
   )
-import Data.IORef (IORef, newIORef, atomicModifyIORef')
+import Data.IORef (newIORef, atomicModifyIORef')
 import Data.Maybe (fromJust)
-import Data.Typeable (Typeable)
+import qualified Data.Map.Strict as Map
+  ( size
+  , insert
+  , delete
+  , lookup
+  , empty
+  , foldrWithKey
+  )
 
 --------------------------------------------------------------------------------
 -- Priority Mailbox Handling                                                  --
 --------------------------------------------------------------------------------
 
--- represent a max-backlog from RecvTimeoutPolicy
-type Limit = Maybe Int
-
--- our priority queue
-type Queue = PriorityQ Int Message
-
-data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
-                                   , procDef     :: ProcessDefinition s
-                                   , procPrio    :: [DispatchPriority s]
-                                   , procFilters :: [DispatchFilter s]
-                                   , usrTimeout  :: Delay
-                                   , sysTimeout  :: Timer
-                                   , internalQ   :: Queue
-                                   , procState   :: s
-                                   }
-type State s = IORef (ProcessState s)
-
-newtype GenProcess s a = GenProcess {
-   unManaged :: ST.StateT (State s) Process a
- }
- deriving ( Functor
-          , Monad
-          , ST.MonadState (State s)
-          , MonadIO
-          , MonadFix
-          , Typeable
-          , Applicative
-          )
-
-instance forall s . MonadThrow (GenProcess s) where
-  throwM = lift . Catch.throwM
-
-instance forall s . MonadCatch (GenProcess s) where
-  catch p h = do
-    pSt <- ST.get
-    -- we can throw away our state since it is always accessed via an IORef
-    (a, _) <- lift $ Catch.catch (runProcess pSt p) (runProcess pSt . h)
-    return a
-
-instance forall s . MonadMask (GenProcess s) where
-  mask p = do
-      pSt <- ST.get
-      lift $ mask $ \restore -> do
-        (a, _) <- runProcess pSt (p (liftRestore restore))
-        return a
-    where
-      liftRestore restoreP = \p2 -> do
-        ourSTate <- ST.get
-        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
-        return a'
-
-  uninterruptibleMask p = do
-      pSt <- ST.get
-      (a, _) <- lift $ uninterruptibleMask $ \restore ->
-        runProcess pSt (p (liftRestore restore))
-      return a
-    where
-      liftRestore restoreP = \p2 -> do
-        ourSTate <- ST.get
-        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
-        return a'
-
-runProcess :: State s -> GenProcess s a -> Process (a, State s)
-runProcess state proc = ST.runStateT (unManaged proc) state
-
-lift :: Process a -> GenProcess s a
-lift p = GenProcess $ ST.lift p
-
-liftIO :: IO a -> GenProcess s a
-liftIO = lift . P.liftIO
-
 gets :: forall s a . (ProcessState s -> a) -> GenProcess s a
 gets f = ST.get >>= \(s :: State s) -> liftIO $ do
   atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', f s' :: a)
@@ -195,8 +121,8 @@ modifyState f =
   ST.get >>= \s -> liftIO $ mask_ $ do
     atomicModifyIORef' s $ \s' -> (f s', ())
 
-getAndModifyState :: (ProcessState s
-                  -> (ProcessState s, a)) -> GenProcess s a
+getAndModifyState :: (ProcessState s -> (ProcessState s, a))
+                  -> GenProcess s a
 getAndModifyState f =
   ST.get >>= \s -> liftIO $ mask_ $ do
     atomicModifyIORef' s $ \s' -> f s'
@@ -212,6 +138,27 @@ setUserTimeout :: Delay -> GenProcess s ()
 setUserTimeout d =
   modifyState $ \st@ProcessState{..} -> st { usrTimeout = d }
 
+addUserTimer :: Timer -> Message -> GenProcess s TimerKey
+addUserTimer t m =
+  getAndModifyState $ \st@ProcessState{..} ->
+    let sz = Map.size usrTimers
+        tk = sz + 1
+    in (st { usrTimers = (Map.insert tk (t, m) usrTimers) }, tk)
+
+removeUserTimer :: TimerKey -> GenProcess s ()
+removeUserTimer i =
+  modifyState $ \st@ProcessState{..} -> st { usrTimers = (Map.delete i usrTimers) }
+
+consumeTimer :: forall s a . TimerKey -> (Message -> GenProcess s a) -> GenProcess s a
+consumeTimer k f = do
+  mt <- gets usrTimers
+  let tm = Map.lookup k mt
+  let ut = Map.delete k mt
+  modifyState $ \st@ProcessState{..} -> st { usrTimers = ut }
+  case tm of
+    Nothing     -> lift $ die $ "GenProcess.consumeTimer - InvalidTimerKey"
+    Just (_, m) -> f m
+
 processDefinition :: GenProcess s (ProcessDefinition s)
 processDefinition = gets procDef
 
@@ -259,6 +206,13 @@ peek = getAndModifyState $ \st -> do
          let pq = internalQ st
          (st, Q.peek pq)
 
+push :: forall s . Message -> GenProcess s ()
+push m = do
+  st <- processState
+  enqueueMessage st [ PrioritiseInfo {
+    prioritise = (\_ m' ->
+      return $ Just ((-100 :: Int), m')) :: s -> Message -> Process (Maybe (Int, Message)) } ] m
+
 enqueueMessage :: forall s . s
                -> [DispatchPriority s]
                -> Message
@@ -341,7 +295,8 @@ precvLoop ppDef pState recvDelay = do
                                            , procDef     = processDef ppDef
                                            , procPrio    = priorities ppDef
                                            , procFilters = filters ppDef
-                                          }
+                                           , usrTimers   = Map.empty
+                                           }
 
   mask $ \restore -> do
     res <- catch (fmap Right $ restore $ loop st)
@@ -387,6 +342,7 @@ recvQueue = do
 
     nextAction :: ProcessAction s -> GenProcess s ExitReason
     nextAction ac
+      | ProcessActivity  act     <- ac = act >> recvQueue
       | ProcessSkip              <- ac = recvQueue
       | ProcessContinue  ps'     <- ac = recvQueueAux ps'
       | ProcessTimeout   d   ps' <- ac = setUserTimeout d >> recvQueueAux ps'
@@ -496,7 +452,9 @@ recvQueue = do
       ps <- processState
       pd <- processDefinition
       pp <- processPriorities
-      let ms = matchAny (return . Right) : (mkMatchers ps pd)
+      ut <- gets usrTimers
+      let ts = Map.foldrWithKey (\k (t, _) ms -> ms ++ matchKey k t) [] ut
+      let ms = matchAny (return . Right) : (mkMatchers ps pd) ++ ts
       timerAcc <- timeoutPolicy >>= \spec -> case spec of
                                                RecvTimer      _   -> return Nothing
                                                RecvMaxBacklog cnt -> return $ Just cnt
@@ -517,10 +475,15 @@ recvQueue = do
     drainAux ps' pp' maxbq ms = do
       (cnt, m) <- scanMailbox maxbq ms
       case m of
-        Nothing                     -> return ()
-        Just (Left (_ :: TimedOut)) -> return ()
-        Just (Right m')             -> do enqueueMessage ps' pp' m'
-                                          drainAux ps' pp' cnt ms
+        Nothing               -> return ()
+        Just (Right m')       -> do enqueueMessage ps' pp' m'
+                                    drainAux ps' pp' cnt ms
+        Just (Left TimedOut)  -> return ()
+        Just (Left (Yield i)) ->
+          -- we saw a user defined timer fire, and will have an associated message...
+          -- this is a bit complex, we have to enqueue the message and remove the timer
+          -- the latter part of which is handled for us by consumeTimer
+          consumeTimer i push >> drainAux ps' pp' cnt ms
 
     maybeStartTimer :: GenProcess s Timer
     maybeStartTimer = do
@@ -547,9 +510,10 @@ recvQueue = do
       pd <- processDefinition
       ps <- processState
       ud <- currentTimeout
+      mr <- mkMatchRunners
       let ump     = unhandledMessagePolicy pd
           hto     = timeoutHandler pd
-          matches = ((matchMessage return):map (matchExtern ump ps) (externHandlers pd))
+          matches = mr ++ ((matchMessage return):map (matchExtern ump ps) (externHandlers pd))
           recv    = case ud of
                       Infinity -> lift $ fmap Just (receiveWait matches)
                       NoDelay  -> lift $ receiveTimeout 0 matches
@@ -566,6 +530,20 @@ recvQueue = do
             -- listening mode until we hit RecvTimeoutPolicy
             restore $ return ProcessSkip
 
+    mkMatchRunners :: GenProcess s [Match Message]
+    mkMatchRunners = do
+      ut <- gets usrTimers
+      fn <- mkRunner
+      let ms = Map.foldrWithKey (\k (t, _) ms -> ms ++ matchRun fn k t) [] ut
+      return ms
+
+    mkRunner :: GenProcess s (TimerKey -> Process Message)
+    mkRunner = do
+      st <- ST.get
+      let fn = \k -> do (m, _) <- runProcess st (consumeTimer k return)
+                        return m
+      return fn
+
     mkMatchers :: s
                 -> ProcessDefinition s
                 -> [Match (Either TimedOut Message)]
@@ -664,6 +642,7 @@ recvLoop pDef pState recvDelay =
         (ProcessHibernate d' s')  -> block d' >> recvLoop pDef s' recvDelay
         (ProcessStop r) -> handleStop (LastKnown pState) r >> return (r :: ExitReason)
         (ProcessStopping s' r)    -> handleStop (LastKnown s') r >> return (r :: ExitReason)
+        (ProcessActivity _)       -> die $ "recvLoop.InvalidState - ProcessActivityNotSupported"
   where
     matchAux :: UnhandledMessagePolicy
              -> s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index f8b45ef..7ab6e94 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -16,6 +16,14 @@
 module Control.Distributed.Process.ManagedProcess.Internal.Types
   ( -- * Exported data types
     InitResult(..)
+  , GenProcess()
+  , runProcess
+  , lift
+  , liftIO
+  , ProcessState(..)
+  , State
+  , Queue
+  , Limit
   , Condition(..)
   , ProcessAction(..)
   , ProcessReply(..)
@@ -71,9 +79,8 @@ module Control.Distributed.Process.ManagedProcess.Internal.Types
   ) where
 
 import Control.Concurrent.STM (STM)
-import Control.Distributed.Process hiding (Message, finally)
-import Control.Monad.Catch (finally)
-import qualified Control.Distributed.Process as P (Message)
+import Control.Distributed.Process hiding (Message, mask, finally, liftIO)
+import qualified Control.Distributed.Process as P (Message, liftIO)
 import Control.Distributed.Process.Serializable
 import Control.Distributed.Process.Extras
   ( Recipient(..)
@@ -83,16 +90,43 @@ import Control.Distributed.Process.Extras
   , Routable(..)
   , NFSerializable
   )
+import Control.Distributed.Process.Extras.Internal.Queue.PriorityQ
+  ( PriorityQ
+  )
 import Control.Distributed.Process.Extras.Internal.Types
   ( resolveOrDie
   )
 import Control.Distributed.Process.Extras.Time
+import Control.Distributed.Process.ManagedProcess.Timer (Timer, TimerKey)
 import Control.DeepSeq (NFData(..))
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.Catch
+  ( catch
+  , throwM
+  , uninterruptibleMask
+  , mask
+  , finally
+  , MonadThrow
+  , MonadCatch
+  , MonadMask
+  )
+import qualified Control.Monad.Catch as Catch
+  ( catch
+  , throwM
+  )
+import Control.Monad.IO.Class (MonadIO)
+import qualified Control.Monad.State.Strict as ST
+  ( MonadState
+  , StateT
+  , get
+  , lift
+  , runStateT
+  )
 import Data.Binary hiding (decode)
+import Data.Map.Strict (Map)
 import Data.Typeable (Typeable)
-
+import Data.IORef (IORef)
 import Prelude hiding (init)
-
 import GHC.Generics
 
 --------------------------------------------------------------------------------
@@ -175,6 +209,80 @@ data InitResult s =
         ^ the process has decided not to continue starting - this is not an error -}
   deriving (Typeable)
 
+-- represent a max-backlog from RecvTimeoutPolicy
+type Limit = Maybe Int
+
+-- our priority queue
+type Queue = PriorityQ Int P.Message
+
+type TimerMap = Map TimerKey (Timer, P.Message)
+
+data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
+                                   , procDef     :: ProcessDefinition s
+                                   , procPrio    :: [DispatchPriority s]
+                                   , procFilters :: [DispatchFilter s]
+                                   , usrTimeout  :: Delay
+                                   , sysTimeout  :: Timer
+                                   , usrTimers   :: TimerMap
+                                   , internalQ   :: Queue
+                                   , procState   :: s
+                                   }
+type State s = IORef (ProcessState s)
+
+newtype GenProcess s a = GenProcess {
+   unManaged :: ST.StateT (State s) Process a
+ }
+ deriving ( Functor
+          , Monad
+          , ST.MonadState (State s)
+          , MonadIO
+          , MonadFix
+          , Typeable
+          , Applicative
+          )
+
+instance forall s . MonadThrow (GenProcess s) where
+  throwM = lift . Catch.throwM
+
+instance forall s . MonadCatch (GenProcess s) where
+  catch p h = do
+    pSt <- ST.get
+    -- we can throw away our state since it is always accessed via an IORef
+    (a, _) <- lift $ Catch.catch (runProcess pSt p) (runProcess pSt . h)
+    return a
+
+instance forall s . MonadMask (GenProcess s) where
+  mask p = do
+      pSt <- ST.get
+      lift $ mask $ \restore -> do
+        (a, _) <- runProcess pSt (p (liftRestore restore))
+        return a
+    where
+      liftRestore restoreP = \p2 -> do
+        ourSTate <- ST.get
+        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
+        return a'
+
+  uninterruptibleMask p = do
+      pSt <- ST.get
+      (a, _) <- lift $ uninterruptibleMask $ \restore ->
+        runProcess pSt (p (liftRestore restore))
+      return a
+    where
+      liftRestore restoreP = \p2 -> do
+        ourSTate <- ST.get
+        (a', _) <- lift $ restoreP $ runProcess ourSTate p2
+        return a'
+
+runProcess :: State s -> GenProcess s a -> Process (a, State s)
+runProcess state proc = ST.runStateT (unManaged proc) state
+
+lift :: Process a -> GenProcess s a
+lift p = GenProcess $ ST.lift p
+
+liftIO :: IO a -> GenProcess s a
+liftIO = lift . P.liftIO
+
 -- | The action taken by a process after a handler has run and its updated state.
 -- See "Control.Distributed.Process.ManagedProcess.Server.continue"
 --     "Control.Distributed.Process.ManagedProcess.Server.timeoutAfter"
@@ -184,6 +292,7 @@ data InitResult s =
 --
 data ProcessAction s =
     ProcessSkip
+  | ProcessActivity  (GenProcess s ()) -- ^ run the given activity
   | ProcessContinue  s              -- ^ continue with (possibly new) state
   | ProcessTimeout   Delay        s -- ^ timeout if no messages are received
   | ProcessHibernate TimeInterval s -- ^ hibernate for /delay/
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index 4a08900..cee54a7 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -77,7 +77,7 @@ import Control.Concurrent.STM (STM, atomically)
 import Control.Distributed.Process hiding (call, Message)
 import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Serializable
-import Control.Distributed.Process.ManagedProcess.Internal.Types
+import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO, lift)
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
   , Routable(..)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index 6babe5b..e40582b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -44,6 +44,8 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
   , Filter()
   , DispatchFilter()
   , Message()
+  , act
+  , runAfter
   ) where
 
 import Control.Distributed.Process hiding (call, Message)
@@ -51,8 +53,12 @@ import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
   )
+import Control.Distributed.Process.Extras.Time (TimeInterval, Delay(Delay))
+import Control.Distributed.Process.ManagedProcess.Internal.GenProcess (addUserTimer)
 import Control.Distributed.Process.ManagedProcess.Internal.Types
+import Control.Distributed.Process.ManagedProcess.Timer (startTimer)
 import Control.Distributed.Process.Serializable
+import Control.Monad (void)
 import Prelude hiding (init)
 
 data RejectedByServer = RejectedByServer deriving (Show)
@@ -184,9 +190,22 @@ ensureM c =
 filterFail :: ExitReason
 filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed"
 
--- | Sets an explicit priority
+act :: forall s . GenProcess s ()
+    -> Action s
+act = return . ProcessActivity
+
+runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> Action s
+runAfter d m = act $ do
+  t <- lift $ startTimer (Delay d)
+  void $ addUserTimer t (unsafeWrapMessage m)
+
+-- | Sets an explicit priority from 1..100. Values > 100 are rounded to 100,
+-- and values < 1 are set to 0.
 setPriority :: Int -> Priority m
-setPriority = Priority
+setPriority n
+  | n < 1     = Priority 0
+  | n > 100   = Priority 100
+  | otherwise = Priority n
 
 -- | Prioritise a call handler, ignoring the server's state
 prioritiseCall_ :: forall s a b . (Serializable a, Serializable b)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
index beeaf30..9ad814a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs
@@ -63,7 +63,7 @@ import Control.Distributed.Process hiding (call, say)
 import qualified Control.Distributed.Process as P (say)
 import Control.Distributed.Process.Extras
   (ExitReason(..))
-import Control.Distributed.Process.ManagedProcess.Internal.Types
+import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (lift)
 import qualified Control.Distributed.Process.ManagedProcess.Server as Server
 import Control.Distributed.Process.Extras.Time
 import Control.Distributed.Process.Serializable
diff --git a/src/Control/Distributed/Process/ManagedProcess/Timer.hs b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
index ab80b1e..9be0128 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Timer.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
@@ -31,14 +31,18 @@
 --
 module Control.Distributed.Process.ManagedProcess.Timer
   ( Timer(timerDelay)
+  , TimerKey
   , delayTimer
   , startTimer
   , stopTimer
   , resetTimer
   , clearTimer
   , matchTimeout
+  , matchKey
+  , matchRun
   , isActive
   , readTimer
+  , checkKey
   , TimedOut(..)
   ) where
 
@@ -46,12 +50,14 @@ import Control.Concurrent (rtsSupportsBoundThreads)
 import Control.Concurrent.STM hiding (check)
 import Control.Distributed.Process
   ( matchSTM
+  , unsafeWrapMessage
   , Process
   , ProcessId
   , Match
   , Message
   , liftIO
   )
+import Control.Distributed.Process.Serializable (Serializable)
 import qualified Control.Distributed.Process as P
   ( liftIO
   )
@@ -71,18 +77,21 @@ import GHC.Generics
 -- Timeout Management                                                         --
 --------------------------------------------------------------------------------
 
+type TimerKey = Int
+
 -- private datum used during STM reads on Timers and to implement
 -- block in terms of listening for a message that will never arrive
-data TimedOut = TimedOut deriving (Eq, Show, Typeable, Generic)
+data TimedOut = TimedOut | Yield Int
+  deriving (Eq, Show, Typeable, Generic)
 instance Binary TimedOut where
 
 -- | We hold timers in 2 states, each described by a Delay.
 -- isActive = isJust . mtSignal
 -- the TimerRef is optional since we only use the Timer module from extras
 -- when we're unable to registerDelay (i.e. not running under -threaded)
-data Timer = Timer { timerDelay  :: Delay
-                   , mtPidRef :: Maybe TimerRef
-                   , mtSignal :: Maybe (TVar Bool)
+data Timer = Timer { timerDelay :: Delay
+                   , mtPidRef   :: Maybe TimerRef
+                   , mtSignal   :: Maybe (TVar Bool)
                    }
 
 -- | @True@ if a @Timer@ is currently active.
@@ -146,6 +155,27 @@ matchTimeout t@Timer{..}
                               (return . Left) ]
     | otherwise  = []
 
+matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)]
+matchKey i t@Timer{..}
+  | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired ->
+                               if expired then return (Yield i) else retry)
+                           (return . Left)]
+  | otherwise  = []
+
+matchRun :: (TimerKey -> Process Message)
+         -> TimerKey
+         -> Timer
+         -> [Match Message]
+matchRun f k t@Timer{..}
+  | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired ->
+                               if expired then return k else retry) f]
+  | otherwise  = []
+
+checkKey :: Timer -> Process Bool
+checkKey t@Timer{..}
+  | isActive t = liftIO $ atomically $ readTVar $ fromJust mtSignal
+  | otherwise  = return False
+
 -- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the
 -- variable is set to true. Will @retry@ in the meanwhile.
 readTimer :: TVar Bool -> STM TimedOut
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index 9af0eca..c1d51cd 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -21,7 +21,7 @@ import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P
 import Control.Distributed.Process.ManagedProcess.Server.Priority
 import Control.Distributed.Process.SysTest.Utils
 import Control.Distributed.Process.Extras.Time
-import Control.Distributed.Process.Extras.Timer
+import Control.Distributed.Process.Extras.Timer hiding (runAfter)
 import Control.Distributed.Process.Serializable()
 import Control.Monad
 import Control.Monad.Catch (catch)
@@ -349,6 +349,33 @@ testInfoPrioritisation result = do
     Left MyAlarmSignal -> stash result True
     _ -> stash result False
 
+testUserTimerHandling :: TestResult Bool -> Process ()
+testUserTimerHandling result = do
+  us <- getSelfPid
+  let p = (procDef us) `prioritised` ([
+               prioritiseInfo_ (\MyAlarmSignal -> setPriority 100)
+             ] :: [DispatchPriority ()]
+          ) :: PrioritisedProcessDefinition ()
+  pid <- spawnLocal $ pserve () (statelessInit Infinity) p
+  cast pid ()
+  expect >>= stash result . (== MyAlarmSignal)
+  kill pid "goodbye..."
+
+  where
+
+    procDef :: ProcessId -> ProcessDefinition ()
+    procDef us =
+      statelessProcess {
+            apiHandlers = [
+              handleCast (\s () -> runAfter (seconds 5) MyAlarmSignal)
+            ]
+          , infoHandlers = [
+               handleInfo (\s (sig :: MyAlarmSignal) -> send us sig >> continue s)
+            ]
+          , unhandledMessagePolicy = Drop
+          } :: ProcessDefinition ()
+
+
 testCallPrioritisation :: TestResult Bool -> Process ()
 testCallPrioritisation result = do
   pid <- mkPrioritisedServer
@@ -445,6 +472,9 @@ tests transport = do
           , testCase "Complex pre/before filters"
              (delayedAssertion "expected verifiable filter actions"
               localNode True testFilteringBehavior)
+          , testCase "Firing internal timeouts"
+             (delayedAssertion "expected our info handler to run after the timeout"
+              localNode True testUserTimerHandling)
          ]
       ]
 

From 892ce8dbd3211c34157f44953127eeb969a9c936 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Sun, 12 Mar 2017 20:02:57 +0000
Subject: [PATCH 49/50] Expose the GenProcess API a bit more completely

---
 .../Process/ManagedProcess/Server/Priority.hs | 32 ++++++++++++++++---
 tests/TestPrioritisedProcess.hs               |  2 +-
 2 files changed, 28 insertions(+), 6 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index e40582b..eac041a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -46,6 +46,17 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
   , Message()
   , act
   , runAfter
+  , currentTimeout
+  , processState
+  , processDefinition
+  , processFilters
+  , processUnhandledMsgPolicy
+  , setUserTimeout
+  , setProcessState
+  , GenProcess
+  , peek
+  , push
+  , addUserTimer
   ) where
 
 import Control.Distributed.Process hiding (call, Message)
@@ -54,7 +65,19 @@ import Control.Distributed.Process.Extras
   ( ExitReason(..)
   )
 import Control.Distributed.Process.Extras.Time (TimeInterval, Delay(Delay))
-import Control.Distributed.Process.ManagedProcess.Internal.GenProcess (addUserTimer)
+import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
+  ( addUserTimer
+  , currentTimeout
+  , processState
+  , processDefinition
+  , processFilters
+  , processUnhandledMsgPolicy
+  , setUserTimeout
+  , setProcessState
+  , GenProcess
+  , peek
+  , push
+  )
 import Control.Distributed.Process.ManagedProcess.Internal.Types
 import Control.Distributed.Process.ManagedProcess.Timer (startTimer)
 import Control.Distributed.Process.Serializable
@@ -190,12 +213,11 @@ ensureM c =
 filterFail :: ExitReason
 filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed"
 
-act :: forall s . GenProcess s ()
-    -> Action s
+act :: forall s . GenProcess s () -> Action s
 act = return . ProcessActivity
 
-runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> Action s
-runAfter d m = act $ do
+runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> GenProcess s ()
+runAfter d m = do
   t <- lift $ startTimer (Delay d)
   void $ addUserTimer t (unsafeWrapMessage m)
 
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index c1d51cd..d9276c8 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -367,7 +367,7 @@ testUserTimerHandling result = do
     procDef us =
       statelessProcess {
             apiHandlers = [
-              handleCast (\s () -> runAfter (seconds 5) MyAlarmSignal)
+              handleCast (\s () -> act $ runAfter (seconds 5) MyAlarmSignal)
             ]
           , infoHandlers = [
                handleInfo (\s (sig :: MyAlarmSignal) -> send us sig >> continue s)

From 8ad94262693eb66a158dbcd3b3908a2fc0888968 Mon Sep 17 00:00:00 2001
From: Tim Watson <watson.timothy@gmail.com>
Date: Mon, 13 Mar 2017 11:10:38 +0000
Subject: [PATCH 50/50] Haddocks

---
 .../Process/ManagedProcess/Client.hs          |   3 +-
 .../ManagedProcess/Internal/GenProcess.hs     | 103 +++++++++++++++---
 .../Process/ManagedProcess/Internal/Types.hs  |  40 ++++++-
 .../Process/ManagedProcess/Server.hs          |   4 +-
 .../Process/ManagedProcess/Server/Priority.hs |  55 ++++++----
 .../Process/ManagedProcess/Timer.hs           |  24 ++--
 tests/TestPrioritisedProcess.hs               |   2 +-
 7 files changed, 178 insertions(+), 53 deletions(-)

diff --git a/src/Control/Distributed/Process/ManagedProcess/Client.hs b/src/Control/Distributed/Process/ManagedProcess/Client.hs
index 5972f32..32378ec 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Client.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Client.hs
@@ -128,7 +128,7 @@ tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult
 -- undefined, i.e., the server may or may not successfully process the
 -- request and may (or may not) send a response at a later time. From the
 -- callers perspective, this is somewhat troublesome, since the call result
--- cannot be decoded directly. In this case, the 'flushPendingCalls' API /may/
+-- cannot be decoded directly. In this case, the "flushPendingCalls" API /may/
 -- be used to attempt to receive the message later on, however this makes
 -- /no attempt whatsoever/ to guarantee /which/ call response will in fact
 -- be returned to the caller. In those semantics are unsuited to your
@@ -147,6 +147,7 @@ callTimeout s m d = initCall s m >>= waitResponse (Just d) >>= decodeResult
         decodeResult (Just (Right result)) = return $ Just result
         decodeResult (Just (Left reason))  = die reason
 
+-- | Attempt to flush out any pending call responses. 
 flushPendingCalls :: forall b . (Serializable b)
                   => TimeInterval
                   -> (b -> Process b)
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
index 015377b..5f43d6b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs
@@ -30,6 +30,10 @@ module Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   , peek
   , push
   , addUserTimer
+  , removeUserTimer
+  , act
+  , runAfter
+  , evalAfter
   ) where
 
 import Control.Applicative (liftA2)
@@ -45,6 +49,7 @@ import Control.Distributed.Process
   , catchesExit
   , catchExit
   , die
+  , unsafeWrapMessage
   , Process
   , ProcessId
   , Match
@@ -86,6 +91,7 @@ import Control.Distributed.Process.Extras
   )
 import qualified Control.Distributed.Process.Extras.SystemLog as Log
 import Control.Distributed.Process.Extras.Time
+import Control.Distributed.Process.Serializable (Serializable)
 import Control.Monad (void)
 import Control.Monad.Catch
   ( mask_
@@ -112,32 +118,41 @@ import qualified Data.Map.Strict as Map
 -- Priority Mailbox Handling                                                  --
 --------------------------------------------------------------------------------
 
+-- | Evaluate the given function over the @ProcessState s@ for the caller, and
+-- return the result.
 gets :: forall s a . (ProcessState s -> a) -> GenProcess s a
 gets f = ST.get >>= \(s :: State s) -> liftIO $ do
   atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', f s' :: a)
 
+-- | Modify our state.
 modifyState :: (ProcessState s -> ProcessState s) -> GenProcess s ()
 modifyState f =
   ST.get >>= \s -> liftIO $ mask_ $ do
     atomicModifyIORef' s $ \s' -> (f s', ())
 
+-- | Modify our state and return a value (potentially from it).
 getAndModifyState :: (ProcessState s -> (ProcessState s, a))
                   -> GenProcess s a
 getAndModifyState f =
   ST.get >>= \s -> liftIO $ mask_ $ do
     atomicModifyIORef' s $ \s' -> f s'
 
+-- | Set the current process state.
 setProcessState :: s -> GenProcess s ()
 setProcessState st' =
   modifyState $ \st@ProcessState{..} -> st { procState = st' }
 
+-- | Set the mailbox draining timer.
 setDrainTimeout :: Timer -> GenProcess s ()
 setDrainTimeout t = modifyState $ \st@ProcessState{..} -> st { sysTimeout = t }
 
+-- | Set the user timeout applied whilst a prioritised process loop is in
+-- a blocking receive.
 setUserTimeout :: Delay -> GenProcess s ()
 setUserTimeout d =
   modifyState $ \st@ProcessState{..} -> st { usrTimeout = d }
 
+-- | Add a /user timer/, bound to the given datum.
 addUserTimer :: Timer -> Message -> GenProcess s TimerKey
 addUserTimer t m =
   getAndModifyState $ \st@ProcessState{..} ->
@@ -145,10 +160,14 @@ addUserTimer t m =
         tk = sz + 1
     in (st { usrTimers = (Map.insert tk (t, m) usrTimers) }, tk)
 
+-- | Remove a /user timer/, for the given key.
 removeUserTimer :: TimerKey -> GenProcess s ()
 removeUserTimer i =
   modifyState $ \st@ProcessState{..} -> st { usrTimers = (Map.delete i usrTimers) }
 
+-- | Consume the timer with the given @TimerKey@. The timer is removed from the
+-- @ProcessState@ and given to the supplied expression, whose evaluation is given
+-- back to the caller.
 consumeTimer :: forall s a . TimerKey -> (Message -> GenProcess s a) -> GenProcess s a
 consumeTimer k f = do
   mt <- gets usrTimers
@@ -159,41 +178,83 @@ consumeTimer k f = do
     Nothing     -> lift $ die $ "GenProcess.consumeTimer - InvalidTimerKey"
     Just (_, m) -> f m
 
+-- | The @ProcessDefinition@ for the current loop.
 processDefinition :: GenProcess s (ProcessDefinition s)
 processDefinition = gets procDef
 
+-- | The list of prioritisers for the current loop.
 processPriorities :: GenProcess s ([DispatchPriority s])
 processPriorities = gets procPrio
 
+-- | The list of filters for the current loop.
 processFilters :: GenProcess s ([DispatchFilter s])
 processFilters = gets procFilters
 
+-- | Evaluates to the user defined state for the currently executing server loop.
 processState :: GenProcess s s
 processState = gets procState
 
+-- | Evaluates to the @UnhandledMessagePolicy@ for the current loop.
 processUnhandledMsgPolicy :: GenProcess s UnhandledMessagePolicy
 processUnhandledMsgPolicy = gets (unhandledMessagePolicy . procDef)
 
+-- | The @Timer@ for the system timeout. See @drainTimeout@.
 systemTimeout :: GenProcess s Timer
 systemTimeout = gets sysTimeout
 
+-- | The policy for the system timeout. This is used to determine how the loop
+-- should limit the time spent draining the /real/ process mailbox into our
+-- internal priority queue.
 timeoutPolicy :: GenProcess s RecvTimeoutPolicy
 timeoutPolicy = gets timeoutSpec
 
+-- | The @Delay@ for the @drainTimeout@.
 drainTimeout :: GenProcess s Delay
 drainTimeout = gets (timerDelay . sysTimeout)
 
+-- | The current (user supplied) timeout.
 currentTimeout :: GenProcess s Delay
 currentTimeout = gets usrTimeout
 
+-- | Update and store the internal priority queue.
 updateQueue :: (Queue -> Queue) -> GenProcess s ()
 updateQueue f =
   modifyState $ \st@ProcessState{..} -> st { internalQ = f internalQ }
 
+-- | Evaluate any matching /info handler/ with the supplied datum after waiting
+-- for at least @TimeInterval@. The process state (for the resulting @Action s@)
+-- is also given and the process loop will go on as per @Server.continue@.
+--
+-- Informally, evaluating this expression (such that the @Action@ is given as the
+-- result of a handler or filter) will ensure that the supplied message (datum)
+-- is availble for processing no sooner than @TimeInterval@.
+--
+-- Currently, this expression creates an @Action@ that triggers immediate
+-- evaluation in the process loop before continuing with the given state. The
+-- process loop stores a /user timeout/ for the given time interval, which is
+-- trigerred like a wait/drain timeout. This implementation is subject to change.
+evalAfter :: forall s m . (Serializable m) => TimeInterval -> m -> s -> Action s
+evalAfter d m s = act $ runAfter d m >> setProcessState s
+
+-- | Produce an @Action s@ that, if it is the result of a handler, will cause the
+-- server loop to evaluate the supplied expression. This is given in the @GenProcess@
+-- monad, which is intended for internal use only.
+act :: forall s . GenProcess s () -> Action s
+act = return . ProcessActivity
+{-# WARNING act "This interface is intended for internal use only" #-}
+
+-- | Starts a timer and adds it as a /user timeout/.
+runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> GenProcess s ()
+runAfter d m = do
+  t <- lift $ startTimer (Delay d)
+  void $ addUserTimer t (unsafeWrapMessage m)
+{-# WARNING runAfter "This interface is intended for internal use only" #-}
+
 --------------------------------------------------------------------------------
 -- Internal Priority Queue                                                    --
 --------------------------------------------------------------------------------
 
+-- | Dequeue a message from the internal priority queue.
 dequeue :: GenProcess s (Maybe Message)
 dequeue = getAndModifyState $ \st -> do
             let pq = internalQ st
@@ -201,18 +262,24 @@ dequeue = getAndModifyState $ \st -> do
               Nothing      -> (st, Nothing)
               Just (m, q') -> (st { internalQ = q' }, Just m)
 
+-- | Peek at the next available message in the internal priority queue, without
+-- removing it.
 peek :: GenProcess s (Maybe Message)
 peek = getAndModifyState $ \st -> do
          let pq = internalQ st
          (st, Q.peek pq)
 
+-- | Push a message to the head of the internal priority queue.
 push :: forall s . Message -> GenProcess s ()
 push m = do
   st <- processState
   enqueueMessage st [ PrioritiseInfo {
     prioritise = (\_ m' ->
-      return $ Just ((-100 :: Int), m')) :: s -> Message -> Process (Maybe (Int, Message)) } ] m
+      return $ Just ((101 :: Int), m')) :: s -> Message -> Process (Maybe (Int, Message)) } ] m
 
+-- | Enqueue a message in the internal priority queue. The given message will be
+-- evaluated by all the supplied prioritisers, and if none match it, then it will
+-- be assigned the lowest possible priority (i.e. put at the back of the queue).
 enqueueMessage :: forall s . s
                -> [DispatchPriority s]
                -> Message
@@ -342,7 +409,7 @@ recvQueue = do
 
     nextAction :: ProcessAction s -> GenProcess s ExitReason
     nextAction ac
-      | ProcessActivity  act     <- ac = act >> recvQueue
+      | ProcessActivity  act'    <- ac = act' >> recvQueue
       | ProcessSkip              <- ac = recvQueue
       | ProcessContinue  ps'     <- ac = recvQueueAux ps'
       | ProcessTimeout   d   ps' <- ac = setUserTimeout d >> recvQueueAux ps'
@@ -402,20 +469,20 @@ recvQueue = do
                -> Maybe (Filter s)
                -> Message
                -> GenProcess s (ProcessAction s)
-    filterNext mp' fs act msg
-      | Just (FilterSkip s')   <- act = setProcessState s' >> dequeue >> return ProcessSkip
-      | Just (FilterStop s' r) <- act = return $ ProcessStopping s' r
-      | Just (FilterOk s')     <- act
+    filterNext mp' fs mf msg
+      | Just (FilterSkip s')   <- mf = setProcessState s' >> dequeue >> return ProcessSkip
+      | Just (FilterStop s' r) <- mf = return $ ProcessStopping s' r
+      | Just (FilterOk s')     <- mf
       , []                     <- fs = setProcessState s' >> applyNext dequeue processApply
-      | Nothing <- act, []     <- fs = applyNext dequeue processApply
-      | Just (FilterOk s')     <- act
+      | Nothing <- mf, []      <- fs = applyNext dequeue processApply
+      | Just (FilterOk s')     <- mf
       , (f:fs')                <- fs = do
           setProcessState s'
           act' <- lift $ dynHandleFilter s' f msg
           filterNext mp' fs' act' msg
-      | Just (FilterReject _ s') <- act = do
+      | Just (FilterReject _ s') <- mf = do
           setProcessState s' >> dequeue >>= lift . applyPolicy mp' s' . fromJust
-      | Nothing <- act {- filter didn't apply to the input type -}
+      | Nothing <- mf {- filter didn't apply to the input type -}
       , (f:fs') <- fs = processState >>= \s' -> do
           lift (dynHandleFilter s' f msg) >>= \a -> filterNext mp' fs' a msg
 
@@ -443,8 +510,8 @@ recvQueue = do
     processApplyAux (h:hs) p' s' m' = do
      attempt <- lift $ h m'
      case attempt of
-       Nothing  -> processApplyAux hs p' s' m'
-       Just act -> return act
+       Nothing   -> processApplyAux hs p' s' m'
+       Just act' -> return act'
 
     drainMailbox :: GenProcess s ()
     drainMailbox = do
@@ -454,7 +521,7 @@ recvQueue = do
       pp <- processPriorities
       ut <- gets usrTimers
       let ts = Map.foldrWithKey (\k (t, _) ms -> ms ++ matchKey k t) [] ut
-      let ms = matchAny (return . Right) : (mkMatchers ps pd) ++ ts
+      let ms = ts ++ (matchAny (return . Right) : (mkMatchers ps pd))
       timerAcc <- timeoutPolicy >>= \spec -> case spec of
                                                RecvTimer      _   -> return Nothing
                                                RecvMaxBacklog cnt -> return $ Just cnt
@@ -534,7 +601,7 @@ recvQueue = do
     mkMatchRunners = do
       ut <- gets usrTimers
       fn <- mkRunner
-      let ms = Map.foldrWithKey (\k (t, _) ms -> ms ++ matchRun fn k t) [] ut
+      let ms = Map.foldrWithKey (\k (t, _) ms' -> ms' ++ matchRun fn k t) [] ut
       return ms
 
     mkRunner :: GenProcess s (TimerKey -> Process Message)
@@ -662,14 +729,14 @@ recvLoop pDef pState recvDelay =
         -- we've exhausted all the possible info handlers
         m <- dh st msg
         case m of
-          Nothing  -> auxHandler policy st ds msg
-          Just act -> return act
+          Nothing   -> auxHandler policy st ds msg
+          Just act' -> return act'
         -- but here we *do* let the policy kick in
       | otherwise = let dh = dispatchInfo d in do
         m <- dh st msg
         case m of
-          Nothing  -> policy msg
-          Just act -> return act
+          Nothing   -> policy msg
+          Just act' -> return act'
 
     processReceive :: [Match (ProcessAction s)]
                    -> TimeoutHandler s
diff --git a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
index 7ab6e94..4b22a5b 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs
@@ -140,9 +140,11 @@ type CallId = MonitorRef
 newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }
   deriving (Eq, Show, Typeable, Generic)
 
+-- | Retrieve the @Recipient@ for a @CallRef@.
 recipient :: CallRef a -> Recipient
 recipient = fst . unCaller
 
+-- | Retrieve the @CallId@ for a @CallRef@.
 tag :: CallRef a -> CallId
 tag = snd . unCaller
 
@@ -160,10 +162,14 @@ data Message a b =
   | ChanMessage a (SendPort b)
   deriving (Typeable, Generic)
 
+-- | Retrieve the @Recipient@ from a @Message@. If the supplied message is
+-- a /cast/ or /chan/ message will evaluate to @Nothing@, otherwise @Just ref@.
 caller :: forall a b . Message a b -> Maybe Recipient
 caller (CallMessage _ ref) = Just $ recipient ref
 caller _                   = Nothing
 
+-- | Reject a /call/ message with the supplied string. Sends @CallRejected@ to
+-- the recipient if the input is a @CallMessage@, otherwise has no side effects.
 rejectToCaller :: forall a b .
                   Message a b -> String -> Process ()
 rejectToCaller (CallMessage _ ref) m = sendTo ref (CallRejected m (tag ref))
@@ -187,6 +193,8 @@ instance NFSerializable a => NFData (CallResponse a) where
 deriving instance Eq a => Eq (CallResponse a)
 deriving instance Show a => Show (CallResponse a)
 
+-- | Sent to a consumer of the /call/ API when a server filter expression
+-- explicitly rejects an incoming call message.
 data CallRejected = CallRejected String CallId
   deriving (Typeable, Generic, Show, Eq)
 instance Binary CallRejected where
@@ -209,14 +217,16 @@ data InitResult s =
         ^ the process has decided not to continue starting - this is not an error -}
   deriving (Typeable)
 
--- represent a max-backlog from RecvTimeoutPolicy
+-- | Represent a max-backlog from RecvTimeoutPolicy
 type Limit = Maybe Int
 
--- our priority queue
+-- | Internal priority queue, used by prioritised processes.
 type Queue = PriorityQ Int P.Message
 
+-- | Map from @TimerKey@ to @(Timer, Message)@.
 type TimerMap = Map TimerKey (Timer, P.Message)
 
+-- | Internal state of a prioritised process loop.
 data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
                                    , procDef     :: ProcessDefinition s
                                    , procPrio    :: [DispatchPriority s]
@@ -227,8 +237,11 @@ data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy
                                    , internalQ   :: Queue
                                    , procState   :: s
                                    }
+
+-- | Prioritised process state, held as an @IORef@.
 type State s = IORef (ProcessState s)
 
+-- | StateT based monad for prioritised process loops.
 newtype GenProcess s a = GenProcess {
    unManaged :: ST.StateT (State s) Process a
  }
@@ -274,12 +287,15 @@ instance forall s . MonadMask (GenProcess s) where
         (a', _) <- lift $ restoreP $ runProcess ourSTate p2
         return a'
 
+-- | Run an action in the @GenProcess@ monad.
 runProcess :: State s -> GenProcess s a -> Process (a, State s)
 runProcess state proc = ST.runStateT (unManaged proc) state
 
+-- | Lift an action in the @Process@ monad to @GenProcess@.
 lift :: Process a -> GenProcess s a
 lift p = GenProcess $ ST.lift p
 
+-- | Lift an IO action directly into @GenProcess@, @liftIO = lift . Process.LiftIO@.
 liftIO :: IO a -> GenProcess s a
 liftIO = lift . P.liftIO
 
@@ -290,6 +306,10 @@ liftIO = lift . P.liftIO
 --     "Control.Distributed.Process.ManagedProcess.Server.stop"
 --     "Control.Distributed.Process.ManagedProcess.Server.stopWith"
 --
+-- Also see "Control.Distributed.Process.Management.Priority.act" and
+-- "Control.Distributed.Process.ManagedProcess.Priority.runAfter".
+--
+-- And other actions. This type should not be used directly.
 data ProcessAction s =
     ProcessSkip
   | ProcessActivity  (GenProcess s ()) -- ^ run the given activity
@@ -339,10 +359,12 @@ data ExitState s = CleanShutdown s -- ^ given when an ordered shutdown is underw
                  | LastKnown s     {-
                   ^ given due to an unhandled exception, passing the last known state -}
 
+-- | @True@ if the @ExitState@ is @CleanShutdown@, otherwise @False@.
 isCleanShutdown :: ExitState s -> Bool
 isCleanShutdown (CleanShutdown _) = True
 isCleanShutdown _                 = False
 
+-- | Evaluates to the @s@ state datum in the given @ExitState@.
 exitState :: ExitState s -> s
 exitState (CleanShutdown s) = s
 exitState (LastKnown s)     = s
@@ -421,11 +443,15 @@ channelControlPort :: ControlChannel m
                    -> ControlPort m
 channelControlPort cc = ControlPort $ fst $ unControl cc
 
+-- | Given as the result of evaluating a "DispatchFilter". This type is intended
+-- for internal use. For an API for working with filters,
+-- see "Control.Distributed.Process.ManagedProcess.Priority".
 data Filter s = FilterOk s
               | forall m . (Show m) => FilterReject m s
               | FilterSkip s
               | FilterStop s ExitReason
 
+-- | Provides dispatch from a variety of inputs to a typed filter handler.
 data DispatchFilter s =
     forall a b . (Serializable a, Serializable b) =>
     FilterApi
@@ -508,6 +534,8 @@ instance MessageMatcher ExternDispatcher where
   matchDispatch _ s (DispatchCC  c d)     = matchChan c (d s)
   matchDispatch _ s (DispatchSTM c d _ _) = matchSTM  c (d s)
 
+-- | Defines the means of dispatching messages from external channels (e.g.
+-- those defined in terms of "ControlChannel", and STM actions) to a handler.
 class ExternMatcher d where
   matchExtern :: UnhandledMessagePolicy -> s -> d s -> Match P.Message
 
@@ -607,6 +635,10 @@ data ProcessDefinition s = ProcessDefinition {
 -- TODO: Generify this /call/ API and use it in Call.hs to avoid tagging
 
 -- TODO: the code below should be moved elsewhere. Maybe to Client.hs?
+
+-- | The send part of the /call/ client-server interaction. The resulting
+-- "CallRef" can be used to identify the corrolary response message (if one is
+-- sent by the server), and is unique to this /call-reply/ pair.
 initCall :: forall s a b . (Addressable s, Serializable a, Serializable b)
          => s -> a -> Process (CallRef b)
 initCall sid msg = do
@@ -617,6 +649,7 @@ initCall sid msg = do
     sendTo pid (CallMessage msg cRef :: Message a b)
     return cRef
 
+-- | Version of @initCall@ that utilises "unsafeSendTo".
 unsafeInitCall :: forall s a b . ( Addressable s
                                  , NFSerializable a
                                  , NFSerializable b
@@ -630,6 +663,9 @@ unsafeInitCall sid msg = do
     unsafeSendTo pid (CallMessage msg cRef  :: Message a b)
     return cRef
 
+-- | Wait on the server's response after an "initCall" has been previously been sent.
+--
+-- This function does /not/ trap asynchronous exceptions.
 waitResponse :: forall b. (Serializable b)
              => Maybe TimeInterval
              -> CallRef b
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server.hs b/src/Control/Distributed/Process/ManagedProcess/Server.hs
index cee54a7..767245a 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server.hs
@@ -115,9 +115,11 @@ state = State
 input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m
 input = Input
 
+-- | Reject the message we're currently handling.
 reject :: forall r s . s -> String -> Reply r s
 reject st rs = continue st >>= return . ProcessReject rs
 
+-- | Reject the message we're currently handling, giving an explicit reason.
 rejectWith :: forall r m s . (Show r) => s -> r -> Reply m s
 rejectWith st rs = reject st (show rs)
 
@@ -270,7 +272,7 @@ handleCall = handleCallIf $ state (const True)
 
 -- | Constructs a 'call' handler from an ordinary function in the 'Process'
 -- monad. Given a function @f :: (s -> a -> Process (ProcessReply b s))@,
--- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion
+-- the expression @handleCall f@ will yield a "Dispatcher" for inclusion
 -- in a 'Behaviour' specification for the /GenProcess/. Messages are only
 -- dispatched to the handler if the supplied condition evaluates to @True@.
 --
diff --git a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
index eac041a..c5fef74 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs
@@ -38,14 +38,14 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
   , reject
   , rejectApi
   , store
+  , storeM
   , crash
   , ensure
   , ensureM
   , Filter()
   , DispatchFilter()
   , Message()
-  , act
-  , runAfter
+  , evalAfter
   , currentTimeout
   , processState
   , processDefinition
@@ -64,7 +64,6 @@ import qualified Control.Distributed.Process as P (Message)
 import Control.Distributed.Process.Extras
   ( ExitReason(..)
   )
-import Control.Distributed.Process.Extras.Time (TimeInterval, Delay(Delay))
 import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   ( addUserTimer
   , currentTimeout
@@ -77,39 +76,43 @@ import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
   , GenProcess
   , peek
   , push
+  , evalAfter
   )
 import Control.Distributed.Process.ManagedProcess.Internal.Types
-import Control.Distributed.Process.ManagedProcess.Timer (startTimer)
 import Control.Distributed.Process.Serializable
-import Control.Monad (void)
 import Prelude hiding (init)
 
+-- | Sent to a caller in cases where the server is rejecting an API input and
+-- a @Recipient@ is available (i.e. a /call/ message handling filter).
 data RejectedByServer = RejectedByServer deriving (Show)
 
+-- | Represents a pair of expressions that can be used to define a @DispatchFilter@.
 data FilterHandler s =
     forall m . (Serializable m) =>
     HandlePure
     {
       pureCheck :: s -> m -> Process Bool
     , handler :: s -> m -> Process (Filter s)
-    }
+    } -- ^ A pure handler, usable where the target handler is based on @handleInfo@
   | forall m b . (Serializable m, Serializable b) =>
     HandleApi
     {
       apiCheck :: s -> m -> Process Bool
     , apiHandler :: s -> Message m b -> Process (Filter s)
-    }
+    } -- ^ An API handler, usable where the target handler is based on @handle{Call, Cast, RpcChan}@
   | HandleRaw
     {
       rawCheck :: s -> P.Message -> Process Bool
     , rawHandler :: s -> P.Message -> Process (Maybe (Filter s))
-    }
+    } -- ^ A raw handler, usable where the target handler is based on @handleRaw@
   | HandleState { stateHandler :: s -> Process (Maybe (Filter s)) }
 
 {-
 check :: forall c s m . (Check c s m)
       => c -> (s -> Process (Filter s)) -> s -> m -> Process (Filter s)
 -}
+
+-- | Create a filter from a @FilterHandler@.
 check :: forall s . FilterHandler s -> DispatchFilter s
 check h
   | HandlePure{..}  <- h = FilterAny $ \s m -> pureCheck s m >>= procUnless s m handler
@@ -127,58 +130,78 @@ check h
     procUnless s _ _ True  = return $ FilterOk s
     procUnless s m h' False = h' s m
 
+-- | A raw filter (targetting raw messages).
 raw :: forall s .
        (s -> P.Message -> Process Bool)
     -> (s -> P.Message -> Process (Maybe (Filter s)))
     -> FilterHandler s
 raw = HandleRaw
 
+-- | A raw filter that ignores the server state in its condition expression.
 raw_ :: forall s .
         (P.Message -> Process Bool)
      -> (s -> P.Message -> Process (Maybe (Filter s)))
      -> FilterHandler s
 raw_ c h = raw (const $ c) h
 
+-- | An API filter (targetting /call/, /cast/, and /chan/ messages).
 api :: forall s m b . (Serializable m, Serializable b)
     => (s -> m -> Process Bool)
     -> (s -> Message m b -> Process (Filter s))
     -> FilterHandler s
 api = HandleApi
 
+-- | An API filter that ignores the server state in its condition expression.
 api_ :: forall m b s . (Serializable m, Serializable b)
      => (m -> Process Bool)
      -> (s -> Message m b -> Process (Filter s))
      -> FilterHandler s
 api_ c h = api (const $ c) h
 
+-- | An info filter (targetting info messages of a specific type)
 info :: forall s m . (Serializable m)
         => (s -> m -> Process Bool)
         -> (s -> m -> Process (Filter s))
         -> FilterHandler s
 info = HandlePure
 
+-- | An info filter that ignores the server state in its condition expression.
 info_ :: forall s m . (Serializable m)
         => (m -> Process Bool)
         -> (s -> m -> Process (Filter s))
         -> FilterHandler s
 info_ c h = info (const $ c) h
 
+-- | Create a filter expression that will reject all messages of a specific type.
 reject :: forall s m r . (Show r)
        => r -> s -> m -> Process (Filter s)
 reject r = \s _ -> do return $ FilterReject (show r) s
 
+-- | Create a filter expression that will crash (i.e. stop) the server.
 crash :: forall s . s -> ExitReason -> Process (Filter s)
 crash s r = return $ FilterStop s r
 
+-- | A version of @reject@ that deals with API messages (i.e. /call/, /cast/, etc)
+-- and in the case of a /call/ interaction, will reject the messages and reply to
+-- the sender accordingly (with @CallRejected@).
 rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b)
           => r -> s -> Message m b -> Process (Filter s)
 rejectApi r = \s m -> do let r' = show r
                          rejectToCaller m r'
                          return $ FilterSkip s
 
+-- | Modify the server state every time a message is recieved.
 store :: (s -> s) -> DispatchFilter s
 store f = FilterState $ return . Just . FilterOk . f
 
+-- | Motify the server state when messages of a certain type arrive...
+storeM :: forall s m . (Serializable m)
+       => (s -> m -> Process s)
+       -> DispatchFilter s
+storeM proc = check $ HandlePure (\_ _ -> return True)
+                                 (\s m -> proc s m >>= return . FilterOk)
+
+-- | Refuse messages for which the given expression evaluates to @True@.
 refuse :: forall s m . (Serializable m)
        => (m -> Bool)
        -> DispatchFilter s
@@ -191,17 +214,19 @@ apiCheck :: forall s m r . (Serializable m, Serializable r)
       -> (s -> Message m r -> Process (Filter s))
       -> DispatchFilter s
 apiCheck c h = checkM (\s m -> return $ c s m) h
-
-apiReject
 -}
 
+-- | Ensure that the server state is consistent with the given expression each
+-- time a message arrives/is processed. If the expression evaluates to @True@
+-- then the filter will evaluate to "FilterOk", otherwise "FilterStop" (which
+-- will cause the server loop to stop with @ExitOther filterFail@).
 ensure :: forall s . (s -> Bool) -> DispatchFilter s
 ensure c =
   check $ HandleState { stateHandler = (\s -> if c s
                                                 then return $ Just $ FilterOk s
                                                 else return $ Just $ FilterStop s filterFail)
                       }
-
+-- | As @ensure@ but runs in the @Process@ monad, and matches only inputs of type @m@.
 ensureM :: forall s m . (Serializable m) => (s -> m -> Process Bool) -> DispatchFilter s
 ensureM c =
   check $ HandlePure { pureCheck = c
@@ -213,14 +238,6 @@ ensureM c =
 filterFail :: ExitReason
 filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed"
 
-act :: forall s . GenProcess s () -> Action s
-act = return . ProcessActivity
-
-runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> GenProcess s ()
-runAfter d m = do
-  t <- lift $ startTimer (Delay d)
-  void $ addUserTimer t (unsafeWrapMessage m)
-
 -- | Sets an explicit priority from 1..100. Values > 100 are rounded to 100,
 -- and values < 1 are set to 0.
 setPriority :: Int -> Priority m
diff --git a/src/Control/Distributed/Process/ManagedProcess/Timer.hs b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
index 9be0128..092f423 100644
--- a/src/Control/Distributed/Process/ManagedProcess/Timer.hs
+++ b/src/Control/Distributed/Process/ManagedProcess/Timer.hs
@@ -42,7 +42,6 @@ module Control.Distributed.Process.ManagedProcess.Timer
   , matchRun
   , isActive
   , readTimer
-  , checkKey
   , TimedOut(..)
   ) where
 
@@ -50,14 +49,12 @@ import Control.Concurrent (rtsSupportsBoundThreads)
 import Control.Concurrent.STM hiding (check)
 import Control.Distributed.Process
   ( matchSTM
-  , unsafeWrapMessage
   , Process
   , ProcessId
   , Match
   , Message
   , liftIO
   )
-import Control.Distributed.Process.Serializable (Serializable)
 import qualified Control.Distributed.Process as P
   ( liftIO
   )
@@ -77,11 +74,15 @@ import GHC.Generics
 -- Timeout Management                                                         --
 --------------------------------------------------------------------------------
 
+-- | A key for storing timers in prioritised process backing state.
 type TimerKey = Int
 
--- private datum used during STM reads on Timers and to implement
--- block in terms of listening for a message that will never arrive
-data TimedOut = TimedOut | Yield Int
+-- | Used during STM reads on Timers and to implement blocking. Since timers
+-- can be associated with a "TimerKey", the second constructor for this type
+-- yields a key indicating whic "Timer" it refers to. Note that the user is
+-- responsible for establishing and maintaining the mapping between @Timer@s
+-- and their keys.
+data TimedOut = TimedOut | Yield TimerKey
   deriving (Eq, Show, Typeable, Generic)
 instance Binary TimedOut where
 
@@ -155,6 +156,9 @@ matchTimeout t@Timer{..}
                               (return . Left) ]
     | otherwise  = []
 
+-- | Create a match expression for a given @Timer@. When the timer expires
+-- (i.e. the "TVar Bool" is set to @True@), the "Match" will return @Yield i@,
+-- where @i@ is the given "TimerKey".
 matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)]
 matchKey i t@Timer{..}
   | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired ->
@@ -162,6 +166,9 @@ matchKey i t@Timer{..}
                            (return . Left)]
   | otherwise  = []
 
+-- | As "matchKey", but instead of a returning @Yield i@, the generated "Match"
+-- handler evaluates the first argument - and expression from "TimerKey" to
+-- @Process Message@ - to determine its result.
 matchRun :: (TimerKey -> Process Message)
          -> TimerKey
          -> Timer
@@ -171,11 +178,6 @@ matchRun f k t@Timer{..}
                                if expired then return k else retry) f]
   | otherwise  = []
 
-checkKey :: Timer -> Process Bool
-checkKey t@Timer{..}
-  | isActive t = liftIO $ atomically $ readTVar $ fromJust mtSignal
-  | otherwise  = return False
-
 -- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the
 -- variable is set to true. Will @retry@ in the meanwhile.
 readTimer :: TVar Bool -> STM TimedOut
diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs
index d9276c8..4f529d0 100644
--- a/tests/TestPrioritisedProcess.hs
+++ b/tests/TestPrioritisedProcess.hs
@@ -367,7 +367,7 @@ testUserTimerHandling result = do
     procDef us =
       statelessProcess {
             apiHandlers = [
-              handleCast (\s () -> act $ runAfter (seconds 5) MyAlarmSignal)
+              handleCast (\s () -> evalAfter (seconds 5) MyAlarmSignal s)
             ]
           , infoHandlers = [
                handleInfo (\s (sig :: MyAlarmSignal) -> send us sig >> continue s)