DPP-97 #resolve Fixed - Supervisor Shutdown Policies

Supervisors must shut down all their children before exiting
themselves. Previously we shut them down in parallel, yet many of our
restart modes are indicative of inter-relationships between sibling
children. The addition of a `ShutdownMode` provides a way to switch
to a synchronous shutdown sequence and to control the traversal (i.e.,
direction) used.

Author: hyperthunk

src/Control/Distributed/Process/Platform/Supervisor.hs

@@ -239,6 +239,7 @@ module Control.Distributed.Process.Platform.Supervisor
   , RestartMode(..)
   , RestartOrder(..)
   , RestartStrategy(..)
+  , ShutdownMode(..)
   , restartOne
   , restartAll
   , restartLeft
@@ -430,14 +431,21 @@ data RestartMode =
 instance Binary RestartMode where
 instance NFData RestartMode where
 
+data ShutdownMode = SequentialShutdown !RestartOrder
+                      | ParallelShutdown
+  deriving (Typeable, Generic, Show, Eq)
+instance Binary ShutdownMode where
+instance NFData ShutdownMode where
+
 -- | Strategy used by a supervisor to handle child restarts, whether due to
 -- unexpected child failure or explicit restart requests from a client.
 --
 -- Some terminology: We refer to child processes managed by the same supervisor
 -- as /siblings/. When restarting a child process, the 'RestartNone' policy
 -- indicates that sibling processes should be left alone, whilst the 'RestartAll'
 -- policy will cause /all/ children to be restarted (in the same order they were
--- started). ************************************************************************
+-- started).
+--
 -- The other two restart strategies refer to /prior/ and /subsequent/
 -- siblings, which describe's those children's configured position
 -- (i.e., insertion order). These latter modes allow one to control the order
@@ -446,18 +454,19 @@ instance NFData RestartMode where
 --
 data RestartStrategy =
     RestartOne
-    { intensity :: !RestartLimit } -- ^ restart only the failed child process
+    { intensity        :: !RestartLimit
+    } -- ^ restart only the failed child process
   | RestartAll
-    { intensity :: !RestartLimit
-    , mode      :: !RestartMode
+    { intensity        :: !RestartLimit
+    , mode             :: !RestartMode
     } -- ^ also restart all siblings
   | RestartLeft
-    { intensity :: !RestartLimit
-    , mode      :: !RestartMode
+    { intensity        :: !RestartLimit
+    , mode             :: !RestartMode
     } -- ^ restart prior siblings (i.e., prior /start order/)
   | RestartRight
-    { intensity :: !RestartLimit
-    , mode      :: !RestartMode
+    { intensity        :: !RestartLimit
+    , mode             :: !RestartMode
     } -- ^ restart subsequent siblings (i.e., subsequent /start order/)
   deriving (Typeable, Generic, Show)
 instance Binary RestartStrategy where
@@ -542,7 +551,7 @@ instance NFData ChildType where
 data RestartPolicy =
     Permanent  -- ^ a permanent child will always be restarted
   | Temporary  -- ^ a temporary child will /never/ be restarted
-  | Transient  -- ^ a transient child will be restarted only if it terminates abnormally
+  | Transient  -- ^ A transient child will be restarted only if it terminates abnormally
   | Intrinsic  -- ^ as 'Transient', but if the child exits normally, the supervisor also exits normally
   deriving (Typeable, Generic, Eq, Show)
 instance Binary RestartPolicy where
@@ -819,13 +828,14 @@ instance Logger LogSink where
   logMessage (LogProcess client') = logMessage client'
 
 data State = State {
-    _specs         :: ChildSpecs
-  , _active        :: Map ProcessId ChildKey
-  , _strategy      :: RestartStrategy
-  , _restartPeriod :: NominalDiffTime
-  , _restarts      :: [UTCTime]
-  , _stats         :: SupervisorStats
-  , _logger        :: LogSink
+    _specs           :: ChildSpecs
+  , _active          :: Map ProcessId ChildKey
+  , _strategy        :: RestartStrategy
+  , _restartPeriod   :: NominalDiffTime
+  , _restarts        :: [UTCTime]
+  , _stats           :: SupervisorStats
+  , _logger          :: LogSink
+  , shutdownStrategy :: ShutdownMode
   }
 
 --------------------------------------------------------------------------------
@@ -837,13 +847,13 @@ data State = State {
 --
 -- > start = spawnLocal . run
 --
-start :: RestartStrategy -> [ChildSpec] -> Process ProcessId
-start s cs = spawnLocal $ run s cs
+start :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ProcessId
+start rs ss cs = spawnLocal $ run rs ss cs
 
 -- | Run the supplied children using the provided restart strategy.
 --
-run :: RestartStrategy -> [ChildSpec] -> Process ()
-run strategy' specs' = MP.pserve (strategy', specs') supInit serverDefinition
+run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ()
+run rs ss specs' = MP.pserve (rs, ss, specs') supInit serverDefinition
 
 --------------------------------------------------------------------------------
 -- Client Facing API                                                          --
@@ -935,8 +945,8 @@ shutdownAndWait sid = do
 -- Server Initialisation/Startup                                              --
 --------------------------------------------------------------------------------
 
-supInit :: InitHandler (RestartStrategy, [ChildSpec]) State
-supInit (strategy', specs') = do
+supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State
+supInit (strategy', shutdown', specs') = do
   logClient <- Log.client
   let client' = case logClient of
                   Nothing -> LogChan
@@ -946,7 +956,7 @@ supInit (strategy', specs') = do
                     )
                   . (strategy ^= strategy')
                   . (logger   ^= client')
-                  $ emptyState
+                  $ emptyState shutdown'
                   )
   -- TODO: should we return Ignore, as per OTP's supervisor, if no child starts?
   (foldlM initChild initState specs' >>= return . (flip InitOk) Infinity)
@@ -982,15 +992,16 @@ initialised state spec (Right ref) = do
 -- Server Definition/State                                                    --
 --------------------------------------------------------------------------------
 
-emptyState :: State
-emptyState = State {
-    _specs         = Seq.empty
-  , _active        = Map.empty
-  , _strategy      = restartAll
-  , _restartPeriod = (fromIntegral (0 :: Integer)) :: NominalDiffTime
-  , _restarts      = []
-  , _stats         = emptyStats
-  , _logger        = LogChan
+emptyState :: ShutdownMode -> State
+emptyState strat = State {
+    _specs           = Seq.empty
+  , _active          = Map.empty
+  , _strategy        = restartAll
+  , _restartPeriod   = (fromIntegral (0 :: Integer)) :: NominalDiffTime
+  , _restarts        = []
+  , _stats           = emptyStats
+  , _logger          = LogChan
+  , shutdownStrategy = strat
   }
 
 emptyStats :: SupervisorStats
@@ -1218,7 +1229,6 @@ handleMonitorSignal state (ProcessMonitorNotification _ pid reason) = do
 --------------------------------------------------------------------------------
 
 handleShutdown :: State -> ExitReason -> Process ()
--- TODO: stop all our children from left to right...
 handleShutdown state (ExitOther reason) = terminateChildren state >> die reason
 handleShutdown state _                  = terminateChildren state
 
@@ -1260,7 +1270,7 @@ tryRestartBranch rs sp dr st = -- TODO: use DiedReason for logging...
                 RestartAll   _ _ -> childSpecs
                 RestartLeft  _ _ -> subTreeL
                 RestartRight _ _ -> subTreeR
-                _                -> error "IllegalState"
+                _                  -> error "IllegalState"
       proc  = case mode' of
                 RestartEach     _ -> stopStart
                 RestartInOrder  _ -> restartL
@@ -1628,17 +1638,24 @@ filterInitFailures sup pid ex = do
 
 terminateChildren :: State -> Process ()
 terminateChildren state = do
-  let allChildren = toList $ state ^. specs
-  pids <- forM allChildren $ \ch -> do
-    pid <- spawnLocal $ asyncTerminate ch $ (active ^= Map.empty) state
-    void $ monitor pid
-    return pid
-  _ <- collectExits [] pids
-  -- TODO: report errs???
-  return ()
+  case (shutdownStrategy state) of
+    ParallelShutdown -> do
+      let allChildren = toList $ state ^. specs
+      pids <- forM allChildren $ \ch -> do
+        pid <- spawnLocal $ void $ syncTerminate ch $ (active ^= Map.empty) state
+        void $ monitor pid
+        return pid
+      void $ collectExits [] pids
+      -- TODO: report errs???
+    SequentialShutdown ord -> do
+      let specs'      = state ^. specs
+      let allChildren = case ord of
+                          RightToLeft -> Seq.reverse specs'
+                          LeftToRight -> specs'
+      void $ foldlM (flip syncTerminate) state (toList allChildren)
   where
-    asyncTerminate :: Child -> State -> Process ()
-    asyncTerminate (cr, cs) state' = void $ doTerminateChild cr cs state'
+    syncTerminate :: Child -> State -> Process State
+    syncTerminate (cr, cs) state' = doTerminateChild cr cs state'
 
     collectExits :: [DiedReason]
                  -> [ProcessId]
@@ -1667,7 +1684,7 @@ doTerminateChild ref spec state = do
                )
   where
     shutdownComplete :: State -> ProcessId -> DiedReason -> Process State
-    shutdownComplete _ _ DiedNormal               = return $ updateStopped
+    shutdownComplete _      _   DiedNormal        = return $ updateStopped
     shutdownComplete state' pid (r :: DiedReason) = do
       logShutdown (state' ^. logger) chKey pid r >> return state'
 

tests/TestSupervisor.hs

@@ -18,7 +18,7 @@ import Control.Exception (throwIO)
 import Control.Distributed.Process hiding (call, monitor)
 import Control.Distributed.Process.Closure
 import Control.Distributed.Process.Node
-import Control.Distributed.Process.Platform hiding (__remoteTable, send)
+import Control.Distributed.Process.Platform hiding (__remoteTable, send, sendChan)
 -- import Control.Distributed.Process.Platform as Alt (monitor)
 import Control.Distributed.Process.Platform.Test
 import Control.Distributed.Process.Platform.Time
@@ -114,7 +114,7 @@ runInTestContext :: LocalNode
                  -> Assertion
 runInTestContext node lock rs cs proc = do
   Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do
-    sup <- Supervisor.start rs cs
+    sup <- Supervisor.start rs ParallelShutdown cs
     (proc sup) `finally` (exit sup ExitShutdown)
 
 verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process ()
@@ -209,6 +209,44 @@ normalStartStop sup = do
   shutdown sup
   sup `shouldExitWith` DiedNormal
 
+sequentialShutdown :: TestResult (Maybe ()) -> Process ()
+sequentialShutdown result = do
+  (sp, rp) <- newChan
+  (sg, rg) <- newChan
+  core' <- toChildStart $ runCore sp
+  app'  <- toChildStart $ runApp sg
+  let core = (permChild core') { childRegName = Just (LocalName "core")
+                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)
+                               }
+  let app  = (permChild app')  { childRegName = Just (LocalName "app")
+                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)
+                               }
+
+  sup <- Supervisor.start restartRight
+                          (SequentialShutdown RightToLeft)
+                          [core, app]
+
+  () <- receiveChan rg
+  exit sup ExitShutdown
+  res <- receiveChanTimeout (asTimeout $ seconds 2) rp
+
+--  whereis "core" >>= liftIO . putStrLn . ("core :" ++) . show
+--  whereis "app"  >>= liftIO . putStrLn . ("app :" ++) . show
+
+  sleepFor 1 Seconds
+  stash result res
+
+  where
+    runCore :: SendPort () -> Process ()
+    runCore sp = (expect >>= say) `catchExit` (\_ ExitShutdown -> sendChan sp ())
+
+    runApp :: SendPort () -> Process ()
+    runApp sg = do
+      Just pid <- whereis "core"
+      link pid  -- if the real "core" exits first, we go too
+      sendChan sg ()
+      expect >>= say
+
 configuredTemporaryChildExitsWithIgnore ::
      ChildStart
   -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
@@ -973,7 +1011,7 @@ localChildStartLinking :: TestResult Bool -> Process ()
 localChildStartLinking result = do
     s1 <- toChildStart procExpect
     s2 <- toChildStart procLinkExpect
-    pid <- Supervisor.start restartOne [tempWorker s1, tempWorker s2]
+    pid <- Supervisor.start restartOne ParallelShutdown [tempWorker s1, tempWorker s2]
     [(r1, _), (r2, _)] <- listChildren pid
     Just p1 <- resolve r1
     Just p2 <- resolve r2
@@ -1117,6 +1155,10 @@ tests transport = do
                 (withSupervisor restartAll []
                     (withClosure restartWithoutTempChildren
                                  $(mkStaticClosure 'blockIndefinitely)))
+          , testCase "Sequential Shutdown Ordering"
+             (delayedAssertion
+              "expected the shutdown order to hold"
+              localNode (Just ()) sequentialShutdown)
           ]
         , testGroup "Stopping and Restarting Children"
           [