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

Author: hyperthunk

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.

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

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

src/Control/Distributed/Process/ManagedProcess/Server.hs

@@ -399,34 +399,38 @@ 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.
 --
 -- 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
+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,21 +447,21 @@ 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.
 --
 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.

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 ()

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"