Safe Handler Execution

src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs

@@ -118,6 +118,8 @@ import qualified Data.Map.Strict as Map
 -- Priority Mailbox Handling                                                  --
 --------------------------------------------------------------------------------
 
+type Safe = Bool
+
 -- | 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
@@ -459,32 +461,39 @@ recvQueue = do
       (up, pf) <- gets $ liftA2 (,) (unhandledMessagePolicy . procDef) procFilters
       case pf of
         [] -> consumeMessage
-        _  -> filterMessage  (filterNext up pf Nothing)
+        _  -> filterMessage  (filterNext False up pf Nothing)
 
     consumeMessage = applyNext dequeue processApply
     filterMessage = applyNext peek
 
-    filterNext :: UnhandledMessagePolicy
+    filterNext :: Safe
+               -> UnhandledMessagePolicy
                -> [DispatchFilter s]
                -> Maybe (Filter s)
                -> Message
                -> GenProcess s (ProcessAction s)
-    filterNext mp' fs mf msg
+    filterNext isSafe mp' fs mf msg
+      | Just (FilterSafe s')   <- mf = filterNext True mp' fs (Just $ FilterOk s') msg
       | Just (FilterSkip s')   <- mf = setProcessState s' >> dequeue >> return ProcessSkip
       | Just (FilterStop s' r) <- mf = return $ ProcessStopping s' r
+      | isSafe
+      , Just (FilterOk s')     <- mf
+      , []                     <- fs = do setProcessState s'
+                                          act' <- processApply msg
+                                          dequeue >> return act'
       | Just (FilterOk s')     <- mf
       , []                     <- fs = setProcessState s' >> applyNext dequeue processApply
       | 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
+          filterNext isSafe mp' fs' act' msg
       | Just (FilterReject _ s') <- mf = do
           setProcessState s' >> dequeue >>= lift . applyPolicy mp' s' . fromJust
       | 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
+          lift (dynHandleFilter s' f msg) >>= \a -> filterNext isSafe mp' fs' a msg
 
     applyNext :: (GenProcess s (Maybe Message))
               -> (Message -> GenProcess s (ProcessAction s))

src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs

@@ -447,6 +447,7 @@ channelControlPort cc = ControlPort $ fst $ unControl cc
 -- for internal use. For an API for working with filters,
 -- see "Control.Distributed.Process.ManagedProcess.Priority".
 data Filter s = FilterOk s
+              | FilterSafe s
               | forall m . (Show m) => FilterReject m s
               | FilterSkip s
               | FilterStop s ExitReason

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE EmptyDataDecls             #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE AllowAmbiguousTypes        #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -44,6 +45,8 @@ module Control.Distributed.Process.ManagedProcess.Server.Priority
   , ensureM
   , Filter()
   , DispatchFilter()
+  , safe
+  , apiSafe
   , Message()
   , evalAfter
   , currentTimeout
@@ -106,6 +109,10 @@ data FilterHandler s =
     , 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)) }
+  | HandleSafe
+    {
+      safeCheck :: s -> P.Message -> Process Bool
+    } -- ^ A safe wrapper
 
 {-
 check :: forall c s m . (Check c s m)
@@ -125,6 +132,10 @@ check h
       c <- apiCheck s m'
       if c then return $ FilterOk s
            else apiHandler s m
+  | HandleSafe{..}  <- h = FilterRaw $ \s m -> do
+      c <- safeCheck s m
+      let ctr = if c then FilterSafe else FilterOk
+      return $ Just $ ctr s
 
   where
     procUnless s _ _ True  = return $ FilterOk s
@@ -172,6 +183,31 @@ info_ :: forall s m . (Serializable m)
         -> FilterHandler s
 info_ c h = info (const $ c) h
 
+apiSafe :: forall s m b . (Serializable m, Serializable b)
+     => (s -> m -> Maybe b -> Bool)
+     -> DispatchFilter s
+apiSafe c = check $ HandleSafe (go c)
+  where
+--    go :: (s -> m -> Bool) -> s -> m -> Process Bool
+    go c' s (i :: P.Message) = do
+      m <- unwrapMessage i :: Process (Maybe (Message m b))
+      case m of
+        Just (CallMessage m' _) -> return $ c' s m' Nothing
+        Just (CastMessage m')   -> return $ c' s m' Nothing
+        Just (ChanMessage m' _) -> return $ c' s m' Nothing
+        Nothing                 -> return False
+
+safe :: forall s m . (Serializable m)
+     => (s -> m -> Bool)
+     -> DispatchFilter s
+safe c = check $ HandleSafe (go c)
+  where
+    go c' s (i :: P.Message) = do
+      m <- unwrapMessage i :: Process (Maybe m)
+      case m of
+        Just m' -> return $ c' s m'
+        Nothing -> return False
+
 -- | 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)

tests/TestPrioritisedProcess.hs

@@ -270,6 +270,77 @@ testFilteringBehavior result = do
   stash result $ m == 25
   kill pid "done"
 
+testSafeExecutionContext :: TestResult Bool -> Process ()
+testSafeExecutionContext result = do
+  let t = (asTimeout $ seconds 5)
+  (sigSp, rp) <- newChan
+  (wp, lp) <- newChan
+  let def = statelessProcess
+            { apiHandlers  = [ handleCall_ (\(m :: String) -> stranded rp wp Nothing >> return m) ]
+            , infoHandlers = [ handleInfo  (\s (m :: String) -> stranded rp wp (Just m) >> continue s) ]
+            , exitHandlers = [ handleExit  (\_ s (_ :: String) -> continue s) ]
+            } `prioritised` []
+
+  let spec = def { filters = [
+                     safe    (\_ (_ :: String) -> True)
+                   , apiSafe (\_ (_ :: String) (_ :: Maybe String) -> True)
+                   ]
+                 }
+
+  pid <- spawnLocal $ pserve () (statelessInit Infinity) spec
+  send pid "hello"  -- pid can't process this as it's stuck waiting on rp
+
+  sleep $ seconds 3
+  exit pid "ooops"  -- now we force an exit signal once the receiveWait finishes
+  sendChan sigSp () -- and allow the receiveWait to complete
+  send pid "hi again"
+
+  -- at this point, "hello" should still be in the backing queue/mailbox
+  sleep $ seconds 3
+
+  -- We should still be seeing "hello", since the 'safe' block saved us from
+  -- losing a message when we handled and swallowed the exit signal.
+  -- We should not see "hi again" until after "hello" has been processed
+  h <- receiveChanTimeout t lp
+  -- say $ "first response: " ++ (show h)
+  let a1 = h == (Just "hello")
+
+  sleep $ seconds 3
+
+  -- now we should have "hi again" waiting in the mailbox...
+  sendChan sigSp ()  -- we must release the handler a second time...
+  h2 <- receiveChanTimeout t lp
+  -- say $ "second response: " ++ (show h2)
+  let a2 = h2 == (Just "hi again")
+
+  void $ spawnLocal $ call pid "reply-please" >>= sendChan wp
+
+  -- the call handler should be stuck waiting on rp
+  Nothing <- receiveChanTimeout (asTimeout $ seconds 2) lp
+
+  -- now let's force an exit, then release the handler to see if it runs again...
+  exit pid "ooops2"
+
+  sleep $ seconds 2
+  sendChan sigSp ()
+
+  h3 <- receiveChanTimeout t lp
+--  say $ "third response: " ++ (show h3)
+  let a3 = h3 == (Just "reply-please")
+
+  stash result $ a1 && a2 && a3
+
+  where
+
+    stranded :: ReceivePort () -> SendPort String -> Maybe String -> Process ()
+    stranded gate chan str = do
+      -- say $ "stranded with " ++ (show str)
+      void $ receiveWait [ matchChan gate return ]
+      sleep $ seconds 1
+      case str of
+        Nothing -> return ()
+        Just s  -> sendChan chan s
+
 testExternalTimedOverflowHandling :: TestResult Bool -> Process ()
 testExternalTimedOverflowHandling result = do
   (pid, cp) <- launchStmOverloadServer -- default 10k mailbox drain limit
@@ -475,6 +546,9 @@ tests transport = do
           , testCase "Firing internal timeouts"
              (delayedAssertion "expected our info handler to run after the timeout"
               localNode True testUserTimerHandling)
+          , testCase "Creating 'Safe' Handlers"
+             (delayedAssertion "expected our handler to run on the old message"
+              localNode True testSafeExecutionContext)
          ]
       ]