distributed-process-supervisor 0.1.3.2 → 0.2.1

raw patch · 9 files changed

+1220/−825 lines, 9 filesdep +exceptionsdep +randomdep −derivedep −template-haskelldep −uniplatedep ~ansi-terminaldep ~basedep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, random

Dependencies removed: derive, template-haskell, uniplate

Dependency ranges changed: ansi-terminal, base, binary, bytestring, containers, data-accessor, distributed-process, distributed-process-client-server, distributed-process-extras, distributed-static, hashable, network-transport, network-transport-tcp, stm, time, unordered-containers

API changes (from Hackage documentation)

Files

• ChangeLog +4/−0
• LICENCE +0/−30
• LICENSE +30/−0
• distributed-process-supervisor.cabal +67/−26
• src/Control/Distributed/Process/Supervisor.hs +327/−298
• src/Control/Distributed/Process/Supervisor/Management.hs +137/−0
• src/Control/Distributed/Process/Supervisor/Types.hs +127/−50
• tests/TestSupervisor.hs +521/−416
• tests/TestUtils.hs +7/−5

@@ -1,3 +1,7 @@+2018-06-14 Facundo Domínguez <facundo.dominguez@tweag.io> 0.2.1++* Update dependency bounds.+ 2016-02-16 Facundo Domínguez <facundo.dominguez@tweag.io> 0.1.3.2  * Update dependency bounds.

@@ -1,30 +0,0 @@-Copyright Tim Watson, 2012-2013.--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the author nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,30 @@+Copyright Tim Watson, 2012-2013.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the author nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,13 +1,12 @@ name:           distributed-process-supervisor-version:        0.1.3.2+version:        0.2.1 cabal-version:  >=1.8 build-type:     Simple license:        BSD3-license-file:   LICENCE-stability:      experimental+license-file:   LICENSE 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-supervisor Bug-Reports:    http://github.com/haskell-distributed/distributed-process-supervisor/issues@@ -21,7 +20,7 @@                  For detailed information see "Control.Distributed.Process.Supervisor" category:       Control-tested-with:    GHC == 7.4.2 GHC == 7.6.2+tested-with:    GHC == 8.2.2 data-dir:       "" extra-source-files: ChangeLog @@ -31,12 +30,14 @@  library   build-depends:-                   base >= 4.4 && < 5,+                   base >= 4.8.2.0 && < 5,+                   bytestring >= 0.9,                    data-accessor >= 0.2.2.3,-                   distributed-process >= 0.5.3 && < 0.7,-                   distributed-process-extras >= 0.2.0 && < 0.3,-                   distributed-process-client-server >= 0.1.2 && < 0.2,-                   binary >= 0.6.3.0 && < 0.8,+                   distributed-static >= 0.3.4.0 && < 0.4,+                   distributed-process >= 0.7.3 && < 0.8,+                   distributed-process-extras >= 0.3.1 && < 0.4,+                   distributed-process-client-server >= 0.2.0 && < 0.4,+                   binary >= 0.6.3.0 && < 0.9,                    deepseq >= 1.3.0.1 && < 1.5,                    mtl,                    containers >= 0.4 && < 0.6,@@ -44,54 +45,94 @@                    unordered-containers >= 0.2.3.0 && < 0.3,                    fingertree < 0.2,                    stm >= 2.4 && < 2.5,-                   time > 1.4 && < 1.6,-                   transformers-  if impl(ghc <= 7.5)-    Build-Depends:   template-haskell == 2.7.0.0,-                     derive == 2.5.5,-                     uniplate == 1.6.12,-                     ghc-prim+                   time > 1.4 && < 1.9,+                   transformers,+                   exceptions >= 0.8.3 && < 0.11   extensions:      CPP   hs-source-dirs:   src   ghc-options:      -Wall   exposed-modules:                    Control.Distributed.Process.Supervisor+                   Control.Distributed.Process.Supervisor.Management   other-modules:                    Control.Distributed.Process.Supervisor.Types  test-suite SupervisorTests   type:            exitcode-stdio-1.0   build-depends:-                   base >= 4.4 && < 5,-                   ansi-terminal >= 0.5 && < 0.7,+                   base >= 4.8.2.0 && < 5,+                   ansi-terminal >= 0.5 && < 0.9,                    containers,                    unordered-containers,                    hashable,-                   distributed-process >= 0.5.3 && < 0.7,+                   distributed-static >= 0.3.5.0 && < 0.4,+                   distributed-process >= 0.7.3 && < 0.8,                    distributed-process-supervisor,+                   distributed-process-extras >= 0.3 && < 0.4,+                   distributed-process-client-server,+                   distributed-static,+                   bytestring,+                   random,+                   data-accessor,+                   fingertree < 0.2,+                   network-transport >= 0.4 && < 0.5.3,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.7,+                   binary >= 0.6.3.0 && < 0.9,+                   deepseq >= 1.3.0.1 && < 1.5,+                   network >= 2.3 && < 2.7,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.9,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim,+                   exceptions >= 0.8.3 && < 0.11+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestSupervisor.hs+  other-modules:   TestUtils++test-suite NonThreadedSupervisorTests+  type:            exitcode-stdio-1.0+  build-depends:+                   base >= 4.8.2.0 && < 5,+                   ansi-terminal >= 0.5 && < 0.9,+                   containers,+                   unordered-containers,+                   hashable,+                   distributed-static >= 0.3.5.0 && < 0.4,+                   distributed-process >= 0.7.3 && < 0.8,+                   distributed-process-supervisor,                    distributed-process-extras,                    distributed-process-client-server,                    distributed-static,                    bytestring,+                   random,                    data-accessor,                    fingertree < 0.2,-                   network-transport >= 0.4 && < 0.5,+                   network-transport >= 0.4 && < 0.5.3,                    mtl,-                   network-transport-tcp >= 0.4 && < 0.6,-                   binary >= 0.6.3.0 && < 0.8,+                   network-transport-tcp >= 0.4 && < 0.7,+                   binary >= 0.6.3.0 && < 0.9,                    deepseq >= 1.3.0.1 && < 1.5,                    network >= 2.3 && < 2.7,                    HUnit >= 1.2 && < 2,                    stm >= 2.3 && < 2.5,-                   time > 1.4 && < 1.6,+                   time > 1.4 && < 1.9,                    test-framework >= 0.6 && < 0.9,                    test-framework-hunit,                    transformers,                    rematch >= 0.2.0.0,-                   ghc-prim+                   ghc-prim,+                   exceptions >= 0.8.3 && < 0.11   hs-source-dirs:                    tests-  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  ghc-options:     -Wall -rtsopts -fno-warn-unused-do-bind -fno-warn-name-shadowing   extensions:      CPP   main-is:         TestSupervisor.hs   other-modules:   TestUtils

@@ -6,7 +6,6 @@ {-# LANGUAGE PatternGuards             #-} {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE OverlappingInstances      #-}  ----------------------------------------------------------------------------- -- |@@ -25,26 +24,20 @@ -- hierarchical process structure called a supervision tree, which provides -- a convenient structure for building fault tolerant software. ----- Unless otherwise stated, all functions in this module will cause the calling--- process to exit unless the specified supervisor process exists.+-- Unless otherwise stated, all client functions in this module will cause the+-- calling process to exit unless the specified supervisor process can be resolved. -- -- [Supervision Principles] -- -- A supervisor is responsible for starting, stopping and monitoring its child -- processes so as to keep them alive by restarting them when necessary. ----- The supervisors children are defined as a list of child specifications--- (see 'ChildSpec'). When a supervisor is started, its children are started+-- The supervisor's children are defined as a list of child specifications+-- (see "ChildSpec"). When a supervisor is started, its children are started -- in left-to-right (insertion order) according to this list. When a supervisor--- stops (or exits for any reason), it will terminate its children in reverse--- (i.e., from right-to-left of insertion) order. Child specs can be added to--- the supervisor after it has started, either on the left or right of the--- existing list of children.------ When the supervisor spawns its child processes, they are always linked to--- their parent (i.e., the supervisor), therefore even if the supervisor is--- terminated abruptly by an asynchronous exception, the children will still be--- taken down with it, though somewhat less ceremoniously in that case.+-- stops (or exits for any reason), it will stop all its children before exiting.+-- Child specs can be added to the supervisor after it has started, either on+-- the left or right of the existing list of child specs. -- -- [Restart Strategies] --@@ -53,7 +46,7 @@ -- (see below for the rules governing child restart eligibility). Each restart -- strategy comprises a 'RestartMode' and 'RestartLimit', which govern how -- the restart should be handled, and the point at which the supervisor--- should give up and terminate itself respectively.+-- should give up and stop itself respectively. -- -- With the exception of the @RestartOne@ strategy, which indicates that the -- supervisor will restart /only/ the one individual failing child, each@@ -142,7 +135,7 @@ -- restarts. In order prevent this, each restart strategy is parameterised -- with a 'RestartLimit' that caps the number of restarts allowed within a -- specific time period. If the supervisor exceeds this limit, it will stop,--- terminating all its children (in left-to-right order) and exit with the+-- stopping all its children (in left-to-right order) and exit with the -- reason @ExitOther "ReachedMaxRestartIntensity"@. -- -- The 'MaxRestarts' type is a positive integer, and together with a specified@@ -153,55 +146,59 @@ -- as a single restart attempt, since otherwise it would likely exceed its -- maximum restart intensity too quickly. ----- [Child Restart and Termination Policies]+-- [Child Restart and Stop Policies] -- -- When the supervisor detects that a child has died, the 'RestartPolicy' -- configured in the child specification is used to determin what to do. If -- the this is set to @Permanent@, then the child is always restarted. -- If it is @Temporary@, then the child is never restarted and the child -- specification is removed from the supervisor. A @Transient@ child will--- be restarted only if it terminates /abnormally/, otherwise it is left+-- be restarted only if it exits /abnormally/, otherwise it is left -- inactive (but its specification is left in place). Finally, an @Intrinsic@ -- child is treated like a @Transient@ one, except that if /this/ kind of child -- exits /normally/, then the supervisor will also exit normally. ----- When the supervisor does terminate a child, the 'ChildTerminationPolicy'+-- When the supervisor does stop a child process, the "ChildStopPolicy" -- provided with the 'ChildSpec' determines how the supervisor should go--- about doing so. If this is @TerminateImmediately@, then the child will+-- about doing so. If this is "StopImmediately", then the child will -- be killed without further notice, which means the child will /not/ have -- an opportunity to clean up any internal state and/or release any held--- resources. If the policy is @TerminateTimeout delay@ however, the child+-- resources. If the policy is @StopTimeout delay@ however, the child -- will be sent an /exit signal/ instead, i.e., the supervisor will cause -- the child to exit via @exit childPid ExitShutdown@, and then will wait -- until the given @delay@ for the child to exit normally. If this does not -- happen within the given delay, the supervisor will revert to the more--- aggressive @TerminateImmediately@ policy and try again. Any errors that+-- aggressive "StopImmediately" policy and try again. Any errors that -- occur during a timed-out shutdown will be logged, however exit reasons--- resulting from @TerminateImmediately@ are ignored.+-- resulting from "StopImmediately" are ignored. -- -- [Creating Child Specs] -- -- The 'ToChildStart' typeclass simplifies the process of defining a 'ChildStart'--- providing three default instances from which a 'ChildStart' datum can be+-- providing two default instances from which a 'ChildStart' datum can be -- generated. The first, takes a @Closure (Process ())@, where the enclosed -- action (in the @Process@ monad) is the actual (long running) code that we -- wish to supervise. In the case of a /managed process/, this is usually the -- server loop, constructed by evaluating some variant of @ManagedProcess.serve@. ----- The other two instances provide a means for starting children without having--- to provide a @Closure@. Both instances wrap the supplied @Process@ action in--- some necessary boilerplate code, which handles spawning a new process and--- communicating its @ProcessId@ to the supervisor. The instance for--- @Addressable a => SupervisorPid -> Process a@ is special however, since this--- API is intended for uses where the typical interactions with a process take--- place via an opaque handle, for which an instance of the @Addressable@--- typeclass is provided. This latter approach requires the expression which is--- responsible for yielding the @Addressable@ handle to handling linking the--- target process with the supervisor, since we have delegated responsibility--- for spawning the new process and cannot perform the link oepration ourselves.+-- The second instance supports returning a /handle/ which can contain extra+-- data about the child process - usually this is a newtype wrapper used by+-- clients to communicate with the process. ----- [Supervision Trees & Supervisor Termination]+-- When the supervisor spawns its child processes, they should be linked to their+-- parent (i.e., the supervisor), such that even if the supervisor is killed+-- abruptly by an asynchronous exception, the children will still be taken down+-- with it, though somewhat less ceremoniously in that case. This behaviour is+-- injected by the supervisor for any "ChildStart" built on @Closure (Process ())@+-- automatically, but the /handle/ based approach requires that the @Closure@+-- responsible for spawning does the linking itself. --+-- Finally, we provide a simple shortcut to @staticClosure@, for consumers+-- who've manually registered with the /remote table/ and don't with to use+-- tempate haskell (e.g. users of the Explicit closures API).+--+-- [Supervision Trees & Supervisor Shutdown]+-- -- To create a supervision tree, one simply adds supervisors below one another -- as children, setting the @childType@ field of their 'ChildSpec' to -- @Supervisor@ instead of @Worker@. Supervision tree can be arbitrarilly@@ -216,7 +213,7 @@     ChildSpec(..)   , ChildKey   , ChildType(..)-  , ChildTerminationPolicy(..)+  , ChildStopPolicy(..)   , ChildStart(..)   , RegisteredName(LocalName, CustomRegister)   , RestartPolicy(..)@@ -228,7 +225,6 @@   , StaticLabel   , SupervisorPid   , ChildPid-  , StarterPid   , ToChildStart(..)   , start   , run@@ -252,8 +248,8 @@   , StartChildResult(..)   , startChild   , startNewChild-  , terminateChild-  , TerminateChildResult(..)+  , stopChild+  , StopChildResult(..)   , deleteChild   , DeleteChildResult(..)   , restartChild@@ -266,6 +262,13 @@   , listChildren   , SupervisorStats(..)   , statistics+  , getRestartIntensity+  , definedChildren+  , definedWorkers+  , definedSupervisors+  , runningChildren+  , runningWorkers+  , runningSupervisors     -- * Additional (Misc) Types   , StartFailure(..)   , ChildInitFailure(..)@@ -274,8 +277,42 @@ import Control.DeepSeq (NFData)  import Control.Distributed.Process.Supervisor.Types-import Control.Distributed.Process hiding (call)-import Control.Distributed.Process.Serializable()+import Control.Distributed.Process+  ( Process+  , ProcessId+  , MonitorRef+  , DiedReason(..)+  , Match+  , Handler(..)+  , Message+  , ProcessMonitorNotification(..)+  , Closure+  , Static+  , exit+  , kill+  , match+  , matchIf+  , monitor+  , getSelfPid+  , liftIO+  , catchExit+  , catchesExit+  , catches+  , die+  , link+  , send+  , register+  , spawnLocal+  , unsafeWrapMessage+  , unmonitor+  , withMonitor_+  , expect+  , unClosure+  , receiveWait+  , receiveTimeout+  , handleMessageIf+  )+import Control.Distributed.Process.Management (mxNotify, MxEvent(MxUser)) import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor) import Control.Distributed.Process.Extras.Internal.Types   ( ExitReason(..)@@ -296,9 +333,11 @@   , ProcessReply   , ProcessDefinition(..)   , PrioritisedProcessDefinition(..)-  , Priority(..)+  , Priority()   , DispatchPriority   , UnhandledMessagePolicy(Drop)+  , ExitState+  , exitState   ) import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe   ( call@@ -312,6 +351,7 @@   , prioritiseCall_   , prioritiseInfo_   , setPriority+  , evalAfter   ) import Control.Distributed.Process.ManagedProcess.Server.Restricted   ( RestrictedProcess@@ -335,9 +375,12 @@   ) import qualified Control.Distributed.Process.Extras.SystemLog as Log import Control.Distributed.Process.Extras.Time+import Control.Distributed.Static+  ( staticClosure+  ) import Control.Exception (SomeException, throwIO)--import Control.Monad.Error+import Control.Monad.Catch (catch, finally, mask)+import Control.Monad (void, forM)  import Data.Accessor   ( Accessor@@ -347,10 +390,10 @@   , (^=)   , (^.)   )-import Data.Binary+import Data.Binary (Binary) import Data.Foldable (find, foldlM, toList) import Data.List (foldl')-import qualified Data.List as List (delete)+import qualified Data.List as List (lookup) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Sequence@@ -395,70 +438,8 @@ instance ToChildStart (Closure (SupervisorPid -> Process (ChildPid, Message))) where   toChildStart = return . CreateHandle ---- StarterProcess variants of ChildStart--expectTriple :: Process (SupervisorPid, ChildKey, SendPort ChildPid)-expectTriple = expect--instance ToChildStart (Process ()) where-  toChildStart proc = do-      starterPid <- spawnLocal $ do-        -- note [linking]: the first time we see the supervisor's pid,-        -- we must link to it, but only once, otherwise we simply waste-        -- time and resources creating duplicate links-        (supervisor, _, sendPidPort) <- expectTriple-        link supervisor-        spawnIt proc supervisor sendPidPort-        tcsProcLoop proc-      return (StarterProcess starterPid)-    where-      tcsProcLoop :: Process () -> Process ()-      tcsProcLoop p = forever' $ do-        (supervisor, _, sendPidPort) <- expectTriple-        spawnIt p supervisor sendPidPort--      spawnIt :: Process ()-              -> SupervisorPid-              -> SendPort ChildPid-              -> Process ()-      spawnIt proc' supervisor sendPidPort = do-        supervisedPid <- spawnLocal $ do-          link supervisor-          self <- getSelfPid-          (proc' `catches` [ Handler $ filterInitFailures supervisor self-                           , Handler $ logFailure supervisor self ])-            `catchesExit` [\_ m -> handleMessageIf m (== ExitShutdown)-                                                    (\_ -> return ())]-        sendChan sendPidPort supervisedPid--instance (Resolvable a) => ToChildStart (SupervisorPid -> Process a) where-  toChildStart proc = do-      starterPid <- spawnLocal $ do-        -- see note [linking] in the previous instance (above)-        (supervisor, _, sendPidPort) <- expectTriple-        link supervisor-        injectIt proc supervisor sendPidPort >> injectorLoop proc-      return $ StarterProcess starterPid-    where-      injectorLoop :: Resolvable a-                   => (SupervisorPid -> Process a)-                   -> Process ()-      injectorLoop p = forever' $ do-        (supervisor, _, sendPidPort) <- expectTriple-        injectIt p supervisor sendPidPort--      injectIt :: Resolvable a-               => (SupervisorPid -> Process a)-               -> SupervisorPid-               -> SendPort ChildPid-               -> Process ()-      injectIt proc' supervisor sendPidPort = do-        addr <- proc' supervisor-        mPid <- resolve addr-        case mPid of-          Nothing -> die "UnresolvableAddress in startChild instance"-          Just p  -> sendChan sendPidPort p+instance ToChildStart (Static (Process ())) where+  toChildStart = toChildStart . staticClosure  -- internal APIs. The corresponding XxxResult types are in -- Control.Distributed.Process.Supervisor.Types@@ -502,16 +483,15 @@ instance Binary RestartChildReq where instance NFData RestartChildReq where -{--data DelayedRestartReq = DelayedRestartReq !ChildKey !DiedReason+data DelayedRestart = DelayedRestart !ChildKey !DiedReason   deriving (Typeable, Generic, Show, Eq)-instance Binary DelayedRestartReq where--}+instance Binary DelayedRestart where+instance NFData DelayedRestart -data TerminateChildReq = TerminateChildReq !ChildKey+data StopChildReq = StopChildReq !ChildKey   deriving (Typeable, Generic, Show, Eq)-instance Binary TerminateChildReq where-instance NFData TerminateChildReq where+instance Binary StopChildReq where+instance NFData StopChildReq where  data IgnoreChildReq = IgnoreChildReq !ChildPid   deriving (Typeable, Generic)@@ -541,6 +521,9 @@   , shutdownStrategy :: ShutdownMode   } +supErrId :: String -> String+supErrId s = "Control.Distributed.Process" ++ s+ -------------------------------------------------------------------------------- -- Starting/Running Supervisor                                                -- --------------------------------------------------------------------------------@@ -598,18 +581,18 @@ startNewChild addr spec = Unsafe.call addr $ AddChild True spec  -- | Delete a supervised child. The child must already be stopped (see--- 'terminateChild').+-- 'stopChild'). -- deleteChild :: Addressable a => a -> ChildKey -> Process DeleteChildResult deleteChild sid childKey = Unsafe.call sid $ DeleteChild childKey --- | Terminate a running child.+-- | Stop a running child. ---terminateChild :: Addressable a+stopChild :: Addressable a                => a                -> ChildKey-               -> Process TerminateChildResult-terminateChild sid = Unsafe.call sid . TerminateChildReq+               -> Process StopChildResult+stopChild sid = Unsafe.call sid . StopChildReq  -- | Forcibly restart a running child. --@@ -619,7 +602,7 @@              -> Process RestartChildResult restartChild sid = Unsafe.call sid . RestartChildReq --- | Gracefully terminate a running supervisor. Returns immediately if the+-- | Gracefully stop/shutdown a running supervisor. Returns immediately if the -- /address/ cannot be resolved. -- shutdown :: Resolvable a => a -> Process ()@@ -638,7 +621,7 @@   mPid <- resolve sid   case mPid of     Nothing -> return ()-    Just p  -> withMonitor p $ do+    Just p  -> withMonitor_ p $ do       shutdown p       receiveWait [ matchIf (\(ProcessMonitorNotification _ p' _) -> p' == p)                             (\_ -> return ())@@ -689,7 +672,7 @@ initialised state spec (Right ref) = do   mPid <- resolve ref   case mPid of-    Nothing  -> die $ (childKey spec) ++ ": InvalidChildRef"+    Nothing  -> die $ (supErrId ".initChild:child=") ++ (childKey spec) ++ ":InvalidChildRef"     Just childPid -> do       return $ ( (active ^: Map.insert childPid chId)                . (specs  ^: (|> (ref, spec)))@@ -733,7 +716,7 @@     supPriorities = [         prioritiseCast_ (\(IgnoreChildReq _)                 -> setPriority 100)       , prioritiseInfo_ (\(ProcessMonitorNotification _ _ _) -> setPriority 99 )---      , prioritiseCast_ (\(DelayedRestartReq _ _)            -> setPriority 80 )+      , prioritiseInfo_ (\(DelayedRestart _ _)               -> setPriority 80 )       , prioritiseCall_ (\(_ :: FindReq) ->                           (setPriority 10) :: Priority (Maybe (ChildRef, ChildSpec)))       ]@@ -744,8 +727,7 @@     apiHandlers = [        Restricted.handleCast   handleIgnore        -- adding, removing and (optionally) starting new child specs-     , handleCall              handleTerminateChild---     , handleCast              handleDelayedRestart+     , handleCall              handleStopChild      , Restricted.handleCall   handleDeleteChild      , Restricted.handleCallIf (input (\(AddChild immediate _) -> not immediate))                                handleAddChild@@ -757,7 +739,9 @@      , Restricted.handleCall   handleListChildren      , Restricted.handleCall   handleGetStats      ]-  , infoHandlers = [handleInfo handleMonitorSignal]+  , infoHandlers = [ handleInfo handleMonitorSignal+                   , handleInfo handleDelayedRestart+                   ]   , shutdownHandler = handleShutdown   , unhandledMessagePolicy = Drop   } :: ProcessDefinition State@@ -883,34 +867,34 @@         Left err         -> reply (ChildRestartFailed err) state         Right (ref, st') -> reply (ChildRestartOk ref) st' -{- handleDelayedRestart :: State-                     -> DelayedRestartReq+                     -> DelayedRestart                      -> Process (ProcessAction State)-handleDelayedRestart state (DelayedRestartReq key reason) =-  let child = findChild key state in+handleDelayedRestart state (DelayedRestart key reason) =+  let child = findChild key state in do   case child of     Nothing ->-      continue state -- a child could've been terminated and removed by now+      continue state -- a child could've been stopped and removed by now     Just ((ChildRestarting childPid), spec) -> do       -- TODO: we ignore the unnecessary .active re-assignments in       -- tryRestartChild, in order to keep the code simple - it would be good to       -- clean this up so we don't have to though...       tryRestartChild childPid state (state ^. active) spec reason--}+    Just other -> do+      die $ ExitOther $ (supErrId ".handleDelayedRestart:InvalidState: ") ++ (show other) -handleTerminateChild :: State-                     -> TerminateChildReq-                     -> Process (ProcessReply TerminateChildResult State)-handleTerminateChild state (TerminateChildReq key) =+handleStopChild :: State+                     -> StopChildReq+                     -> Process (ProcessReply StopChildResult State)+handleStopChild state (StopChildReq key) =   let child = findChild key state in   case child of     Nothing ->-      reply TerminateChildUnknownId state+      reply StopChildUnknownId state     Just (ChildStopped, _) ->-      reply TerminateChildOk state+      reply StopChildOk state     Just (ref, spec) ->-      reply TerminateChildOk =<< doTerminateChild ref spec state+      reply StopChildOk =<< doStopChild ref spec state  handleGetStats :: StatsReq                -> RestrictedProcess State (Result SupervisorStats)@@ -938,9 +922,9 @@ -- Child Monitoring                                                           -- -------------------------------------------------------------------------------- -handleShutdown :: State -> ExitReason -> Process ()-handleShutdown state (ExitOther reason) = terminateChildren state >> die reason-handleShutdown state _                  = terminateChildren state+handleShutdown :: ExitState State -> ExitReason -> Process ()+handleShutdown state r@(ExitOther reason) = stopChildren (exitState state) r >> die reason+handleShutdown state r                    = stopChildren (exitState state) r  -------------------------------------------------------------------------------- -- Child Start/Restart Handling                                               --@@ -955,7 +939,7 @@ tryRestart childPid state active' spec reason = do   sup <- getSelfPid   logEntry Log.debug $ do-    mkReport "tryRestart" sup (childKey spec) (show reason)+    mkReport "signalled restart" sup (childKey spec) (show reason)   case state ^. strategy of     RestartOne _ -> tryRestartChild childPid state active' spec reason     strat        -> do@@ -985,46 +969,55 @@                 RestartRight _ _ -> subTreeR                 _                  -> error "IllegalState"       proc  = case mode' of-                RestartEach     _ -> stopStart-                RestartInOrder  _ -> restartL-                RestartRevOrder _ -> reverseRestart-      dir'  = order mode' in do-    proc tree' dir'+                RestartEach     _ -> stopStart (order mode')+                _                 -> restartBranch mode'+    in do us <- getSelfPid+          a <- proc tree'+          report $ SupervisorBranchRestarted us (childKey sp) dr rs+          return a   where-    stopStart :: ChildSpecs -> RestartOrder -> Process (ProcessAction State)-    stopStart tree order' = do+    stopStart :: RestartOrder -> ChildSpecs -> Process (ProcessAction State)+    stopStart order' tree = do       let tree' = case order' of                     LeftToRight -> tree                     RightToLeft -> Seq.reverse tree       state <- addRestart activeState       case state of-        Nothing  -> die errorMaxIntensityReached+        Nothing  -> do us <- getSelfPid+                       let reason = errorMaxIntensityReached+                       report $ SupervisorShutdown us (shutdownStrategy st) reason+                       die reason         Just st' -> apply (foldlM stopStartIt st' tree') -    reverseRestart :: ChildSpecs-                   -> RestartOrder-                   -> Process (ProcessAction State)-    reverseRestart tree LeftToRight = restartL tree RightToLeft -- force re-order-    reverseRestart tree dir@(RightToLeft) = restartL (Seq.reverse tree) dir--    -- TODO: rename me for heaven's sake - this ISN'T a left biased traversal after all!-    restartL :: ChildSpecs -> RestartOrder -> Process (ProcessAction State)-    restartL tree ro = do-      let rev   = (ro == RightToLeft)-      let tree' = case rev of-                    False -> tree-                    True  -> Seq.reverse tree+    restartBranch :: RestartMode -> ChildSpecs -> Process (ProcessAction State)+    restartBranch mode' tree = do       state <- addRestart activeState       case state of-        Nothing -> die errorMaxIntensityReached-        Just st' -> foldlM stopIt st' tree >>= \s -> do-                     apply $ foldlM startIt s tree'+        Nothing  -> die errorMaxIntensityReached+        Just st' -> do+          let (stopTree, startTree) = mkTrees mode' tree+          foldlM stopIt st' stopTree >>= \s -> apply $ foldlM startIt s startTree +    mkTrees :: RestartMode -> ChildSpecs -> (ChildSpecs, ChildSpecs)+    mkTrees (RestartInOrder LeftToRight)  t = (t, t)+    mkTrees (RestartInOrder RightToLeft)  t = let rev = Seq.reverse t in (rev, rev)+    mkTrees (RestartRevOrder LeftToRight) t = (t, Seq.reverse t)+    mkTrees (RestartRevOrder RightToLeft) t = (Seq.reverse t, t)+    mkTrees _                             _    = error "mkTrees.INVALID_STATE"+     stopStartIt :: State -> Child -> Process State-    stopStartIt s ch@(cr, cs) = doTerminateChild cr cs s >>= (flip startIt) ch+    stopStartIt s ch@(cr, cs) = do+      us <- getSelfPid+      cPid <- resolve cr+      report $ SupervisedChildRestarting us cPid (childKey cs) (ExitOther "RestartedBySupervisor")+      doStopChild cr cs s >>= (flip startIt) ch      stopIt :: State -> Child -> Process State-    stopIt s (cr, cs) = doTerminateChild cr cs s+    stopIt s (cr, cs) = do+      us <- getSelfPid+      cPid <- resolve cr+      report $ SupervisedChildRestarting us cPid (childKey cs) (ExitOther "RestartedBySupervisor")+      doStopChild cr cs s      startIt :: State -> Child -> Process State     startIt s (_, cs)@@ -1043,9 +1036,12 @@                  -> Process State     ensureActive cs it       | (Right (ref, st')) <- it = return $ markActive st' ref cs-      | (Left err) <- it = die $ ExitOther $ (childKey cs) ++ ": " ++ (show err)+      | (Left err) <- it = die $ ExitOther $ branchErrId ++ (childKey cs) ++ ": " ++ (show err)       | otherwise = error "IllegalState" +    branchErrId :: String+    branchErrId = supErrId ".tryRestartBranch:child="+     apply :: (Process State) -> Process (ProcessAction State)     apply proc = do       catchExit (proc >>= continue) (\(_ :: ProcessId) -> stop)@@ -1088,25 +1084,25 @@                        LeftToRight -> tree                        RightToLeft -> Seq.reverse tree -      -- TODO: THIS IS INCORRECT... currently (below), we terminate+      -- TODO: THIS IS INCORRECT... currently (below), we stop       -- the branch in parallel, but wait on all the exits and then       -- restart sequentially (based on 'order'). That's not what the       -- 'RestartParallel' mode advertised, but more importantly, it's       -- not clear what the semantics for error handling (viz restart errors)       -- should actually be. -      asyncs <- forM (toList tree') $ \ch -> async $ asyncTerminate ch+      asyncs <- forM (toList tree') $ \ch -> async $ asyncStop ch       (_errs, st') <- foldlM collectExits ([], activeState) asyncs       -- TODO: report errs       apply $ foldlM startIt st' tree'       where-        asyncTerminate :: Child -> Process (Maybe (ChildKey, ChildPid))-        asyncTerminate (cr, cs) = do+        asyncStop :: Child -> Process (Maybe (ChildKey, ChildPid))+        asyncStop (cr, cs) = do           mPid <- resolve cr           case mPid of             Nothing  -> return Nothing             Just childPid -> do-              void $ doTerminateChild cr cs activeState+              void $ doStopChild cr cs activeState               return $ Just (childKey cs, childPid)          collectExits :: ([ExitReason], State)@@ -1158,14 +1154,16 @@     chKey         = childKey spec  doRestartChild :: ChildPid -> ChildSpec -> DiedReason -> State -> Process (ProcessAction State)-doRestartChild _ spec _ state = do -- TODO: use ChildPid and DiedReason to log+doRestartChild pid spec reason state = do -- TODO: use ChildPid and DiedReason to log   state' <- addRestart state   case state' of-    Nothing -> die errorMaxIntensityReached---      case restartPolicy of---        Restart _            -> die errorMaxIntensityReached---        DelayedRestart _ del -> doRestartDelay oldPid del spec reason state+    Nothing -> -- die errorMaxIntensityReached+      case (childRestartDelay spec) of+        Nothing  -> die errorMaxIntensityReached+        Just del -> doRestartDelay pid del spec reason state     Just st -> do+      sup <- getSelfPid+      report $ SupervisedChildRestarting sup (Just pid) (childKey spec) (ExitOther $ show reason)       start' <- doStartChild spec st       case start' of         Right (ref, st') -> continue $ markActive st' ref spec@@ -1174,7 +1172,6 @@           -- BadClosure and UnresolvableAddress from the StarterProcess           -- variants of ChildStart, which both come back from           -- doStartChild as (Left err).-          sup <- getSelfPid           if isTemporary (childRestart spec)              then do                logEntry Log.warning $@@ -1188,29 +1185,28 @@                  mkReport "Unrecoverable error in child. Stopping supervisor"                  sup (childKey spec) (show err)                stopWith st $ ExitOther $ "Unrecoverable error in child " ++ (childKey spec)-   where     chKey  = childKey spec     chType = childType spec -{-+ doRestartDelay :: ChildPid                -> TimeInterval                -> ChildSpec                -> DiedReason                -> State-               -> Process State+               -> Process (ProcessAction State) doRestartDelay oldPid rDelay spec reason state = do-  self <- getSelfPid-  _ <- runAfter rDelay $ MP.cast self (DelayedRestartReq (childKey spec) reason)-  return $ ( (active ^: Map.filter (/= chKey))-           . (bumpStats Active chType decrement)-           $ maybe state id (updateChild chKey (setChildRestarting oldPid) state)-           )+  evalAfter rDelay+            (DelayedRestart (childKey spec) reason)+          $ ( (active ^: Map.filter (/= chKey))+            . (bumpStats Active chType decrement)+            -- . (restarts ^= [])+            $ maybe state id (updateChild chKey (setChildRestarting oldPid) state)+            )   where     chKey  = childKey spec     chType = childType spec--}  addRestart :: State -> Process (Maybe State) addRestart state = do@@ -1241,7 +1237,7 @@       let mState = updateChild chKey (chRunning p) st       case mState of         -- TODO: better error message if the child is unrecognised-        Nothing -> die $ "InternalError in doStartChild " ++ show spec+        Nothing -> die $ (supErrId ".doStartChild.InternalError:") ++ show spec         Just s' -> return $ Right $ (p, markActive s' p spec)   where     chKey = childKey spec@@ -1262,26 +1258,26 @@                        (\(e :: SomeException) -> return $ Left (show e))         case mProc of           Left err -> logStartFailure $ StartFailureBadClosure err-          Right p  -> wrapClosure childRegName p >>= return . Right+          Right p  -> wrapClosure childKey childRegName p >>= return . Right       CreateHandle fn -> do         mFn <- catch (unClosure fn >>= return . Right)                      (\(e :: SomeException) -> return $ Left (show e))         case mFn of           Left err  -> logStartFailure $ StartFailureBadClosure err           Right fn' -> do-            wrapHandle childRegName fn' >>= return . Right-      StarterProcess starterPid ->-          wrapRestarterProcess childRegName starterPid+            wrapHandle childKey childRegName fn' >>= return . Right   where     logStartFailure sf = do       sup <- getSelfPid-      logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf)+      -- logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf)+      report $ SupervisedChildStartFailure sup sf childKey       return $ Left sf -    wrapClosure :: Maybe RegisteredName+    wrapClosure :: ChildKey+                -> Maybe RegisteredName                 -> Process ()                 -> Process ChildRef-    wrapClosure regName proc = do+    wrapClosure key regName proc = do       supervisor <- getSelfPid       childPid <- spawnLocal $ do         self <- getSelfPid@@ -1289,53 +1285,37 @@         maybeRegister regName self         () <- expect    -- wait for a start signal (pid is still private)         -- we translate `ExitShutdown' into a /normal/ exit-        (proc `catches` [ Handler $ filterInitFailures supervisor self-                        , Handler $ logFailure supervisor self ])+        (proc           `catchesExit` [-            (\_ m -> handleMessageIf m (== ExitShutdown)-                                       (\_ -> return ()))]+              (\_ m -> handleMessageIf m (\r -> r == ExitShutdown)+                                         (\_ -> return ()))+            , (\_ m -> handleMessageIf m (\(ExitOther _) -> True)+                                         (\r -> logExit supervisor self r))+            ])+           `catches` [ Handler $ filterInitFailures supervisor self+                     , Handler $ logFailure supervisor self ]       void $ monitor childPid       send childPid ()-      return $ ChildRunning childPid+      let cRef = ChildRunning childPid+      report $ SupervisedChildStarted supervisor cRef key+      return cRef -    wrapHandle :: Maybe RegisteredName+    wrapHandle :: ChildKey+               -> Maybe RegisteredName                -> (SupervisorPid -> Process (ChildPid, Message))                -> Process ChildRef-    wrapHandle regName proc = do+    wrapHandle key regName proc = do       super <- getSelfPid       (childPid, msg) <- proc super-      maybeRegister regName childPid       void $ monitor childPid-      return $ ChildRunningExtra childPid msg--    wrapRestarterProcess :: Maybe RegisteredName-                         -> StarterPid-                         -> Process (Either StartFailure ChildRef)-    wrapRestarterProcess regName starterPid = do-      sup <- getSelfPid-      (sendPid, recvPid) <- newChan-      ref <- monitor starterPid-      send starterPid (sup, childKey, sendPid)-      ePid <- receiveWait [-                -- TODO: tighten up this contract to correct for erroneous mail-                matchChan recvPid (\(pid :: ChildPid) -> return $ Right pid)-              , matchIf (\(ProcessMonitorNotification mref _ dr) ->-                           mref == ref && dr /= DiedNormal)-                        (\(ProcessMonitorNotification _ _ dr) ->-                           return $ Left dr)-              ] `finally` (unmonitor ref)-      case ePid of-        Right pid -> do-          maybeRegister regName pid-          void $ monitor pid-          return $ Right $ ChildRunning pid-        Left dr -> return $ Left $ StartFailureDied dr-+      maybeRegister regName childPid+      let cRef = ChildRunningExtra childPid msg+      report $ SupervisedChildStarted super cRef key+      return cRef      maybeRegister :: Maybe RegisteredName -> ChildPid -> Process ()     maybeRegister Nothing                         _     = return ()     maybeRegister (Just (LocalName n))            pid   = register n pid-    maybeRegister (Just (GlobalName _))           _     = return ()     maybeRegister (Just (CustomRegister clj))     pid   = do         -- TODO: cache your closures!!!         mProc <- catch (unClosure clj >>= return . Right)@@ -1355,104 +1335,118 @@       -- and matches first before the other handlers that       -- would call logFailure.       -- We log here to avoid silent failure in those cases.-      logEntry Log.error $ mkReport "ChildInitFailure" sup (show childPid) (show ex)+      -- logEntry Log.error $ mkReport "ChildInitFailure" sup (show childPid) (show ex)+      report $ SupervisedChildInitFailed sup childPid ex       liftIO $ throwIO ex     ChildInitIgnore    -> Unsafe.cast sup $ IgnoreChildReq childPid  ----------------------------------------------------------------------------------- Child Termination/Shutdown                                                 --+-- Child Stop/Shutdown                                                 -- -------------------------------------------------------------------------------- -terminateChildren :: State -> Process ()-terminateChildren state = do-  case (shutdownStrategy state) of+stopChildren :: State -> ExitReason -> Process ()+stopChildren state er = do+  us <- getSelfPid+  let strat = shutdownStrategy state+  report $ SupervisorShutdown us strat er+  case strat of     ParallelShutdown -> do       let allChildren = toList $ state ^. specs       terminatorPids <- forM allChildren $ \ch -> do-        pid <- spawnLocal $ void $ syncTerminate ch $ (active ^= Map.empty) state-        void $ monitor pid-        return pid-      terminationErrors <- collectExits [] terminatorPids-      -- it seems these would also be logged individually in doTerminateChild+        pid <- spawnLocal $ void $ syncStop ch $ (active ^= Map.empty) state+        mRef <- monitor pid+        return (mRef, pid)+      terminationErrors <- collectExits [] $ zip terminatorPids (map snd allChildren)+      -- it seems these would also be logged individually in doStopChild       case terminationErrors of         [] -> return ()         _ -> do           sup <- getSelfPid           void $ logEntry Log.error $-            mkReport "Errors in terminateChildren / ParallelShutdown"+            mkReport "Errors in stopChildren / ParallelShutdown"             sup "n/a" (show terminationErrors)     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)+      void $ foldlM (flip syncStop) state (toList allChildren)   where-    syncTerminate :: Child -> State -> Process State-    syncTerminate (cr, cs) state' = doTerminateChild cr cs state'+    syncStop :: Child -> State -> Process State+    syncStop (cr, cs) state' = doStopChild cr cs state'      collectExits :: [(ProcessId, DiedReason)]-                 -> [ChildPid]+                 -> [((MonitorRef, ProcessId), ChildSpec)]                  -> Process [(ProcessId, DiedReason)]     collectExits errors []   = return errors     collectExits errors pids = do-      (pid, reason) <- receiveWait [-          match (\(ProcessMonitorNotification _ pid' reason') -> do-                    return (pid', reason'))+      (ref, pid, reason) <- receiveWait [+          match (\(ProcessMonitorNotification ref' pid' reason') -> do+                    return (ref', pid', reason'))         ]-      let remaining = List.delete pid pids-      case reason of-        DiedNormal -> collectExits errors                 remaining-        _          -> collectExits ((pid, reason):errors) remaining+      let remaining = [p | p <- pids, (snd $ fst p) /= pid]+      let spec = List.lookup (ref, pid) pids+      case (reason, spec) of+        (DiedUnknownId, _) -> collectExits errors remaining+        (DiedNormal, _) -> collectExits errors remaining+        (_, Nothing) -> collectExits errors remaining+        (DiedException _, Just sp') -> do+            if (childStop sp') == StopImmediately+              then collectExits errors remaining+              else collectExits ((pid, reason):errors) remaining+        _ -> collectExits ((pid, reason):errors) remaining -doTerminateChild :: ChildRef -> ChildSpec -> State -> Process State-doTerminateChild ref spec state = do+doStopChild :: ChildRef -> ChildSpec -> State -> Process State+doStopChild ref spec state = do+  us <- getSelfPid   mPid <- resolve ref   case mPid of     Nothing  -> return state -- an already dead child is not an error     Just pid -> do       stopped <- childShutdown (childStop spec) pid state-      state' <- shutdownComplete state pid stopped+      report $ SupervisedChildStopped us ref stopped+      -- state' <- shutdownComplete state pid stopped       return $ ( (active ^: Map.delete pid)-               $ state'+               $ updateStopped                )   where-    shutdownComplete :: State -> ChildPid -> DiedReason -> Process State-    shutdownComplete _      _   DiedNormal        = return $ updateStopped-    shutdownComplete state' pid (r :: DiedReason) = do-      logShutdown (state' ^. logger) chKey pid r >> return state'+    {-shutdownComplete :: State -> ChildPid -> DiedReason -> Process State-}+    {-shutdownComplete _      _   DiedNormal        = return $ updateStopped-}+    {-shutdownComplete state' pid (r :: DiedReason) = do-}+      {-logShutdown (state' ^. logger) chKey pid r >> return state'-}      chKey         = childKey spec     updateStopped = maybe state id $ updateChild chKey (setChildStopped False) state -childShutdown :: ChildTerminationPolicy+childShutdown :: ChildStopPolicy               -> ChildPid               -> State               -> Process DiedReason-childShutdown policy childPid st = do+childShutdown policy childPid st = mask $ \restore -> do   case policy of-    (TerminateTimeout t) -> exit childPid ExitShutdown >> await childPid t st+    (StopTimeout t) -> exit childPid ExitShutdown >> await restore childPid t st     -- we ignore DiedReason for brutal kills-    TerminateImmediately -> do-      kill childPid "TerminatedBySupervisor"-      void $ await childPid Infinity st+    StopImmediately -> do+      kill childPid "StoppedBySupervisor"+      void $ await restore childPid Infinity st       return DiedNormal   where-    await :: ChildPid -> Delay -> State -> Process DiedReason-    await childPid' delay state = do-      let monitored = (Map.member childPid' $ state ^. active)-      let recv = case delay of-                   Infinity -> receiveWait (matches childPid') >>= return . Just-                   NoDelay  -> receiveTimeout 0 (matches childPid')-                   Delay t  -> receiveTimeout (asTimeout t) (matches childPid')+    await restore' childPid' delay state = do       -- We require and additional monitor here when child shutdown occurs       -- during a restart which was triggered by the /old/ monitor signal.-      let recv' =  if monitored then recv else withMonitor childPid' recv-      recv' >>= maybe (childShutdown TerminateImmediately childPid' state) return+      -- Just to be safe, we monitor the child immediately to be sure it goes.+      mRef <- monitor childPid'+      let recv = case delay of+                   Infinity -> receiveWait (matches mRef) >>= return . Just+                   NoDelay  -> receiveTimeout 0 (matches mRef)+                   Delay t  -> receiveTimeout (asTimeout t) (matches mRef)+      -- let recv' =  if monitored then recv else withMonitor childPid' recv+      res <- recv `finally` (unmonitor mRef)+      restore' $ maybe (childShutdown StopImmediately childPid' state) return res -    matches :: ChildPid -> [Match DiedReason]-    matches p = [-          matchIf (\(ProcessMonitorNotification _ p' _) -> p == p')+    matches :: MonitorRef -> [Match DiedReason]+    matches m = [+          matchIf (\(ProcessMonitorNotification m' _ _) -> m == m')                   (\(ProcessMonitorNotification _ _ r) -> return r)         ] @@ -1463,14 +1457,21 @@ errorMaxIntensityReached :: ExitReason errorMaxIntensityReached = ExitOther "ReachedMaxRestartIntensity" -logShutdown :: LogSink -> ChildKey -> ChildPid -> DiedReason -> Process ()-logShutdown log' child childPid reason = do-    sup <- getSelfPid-    Log.info log' $ mkReport banner sup (show childPid) shutdownReason-  where-    banner         = "Child Shutdown Complete"-    shutdownReason = (show reason) ++ ", child-key: " ++ child+report :: MxSupervisor -> Process ()+report = mxNotify . MxUser . unsafeWrapMessage +{-logShutdown :: LogSink -> ChildKey -> ChildPid -> DiedReason -> Process ()-}+{-logShutdown log' child childPid reason = do-}+    {-sup <- getSelfPid-}+    {-Log.info log' $ mkReport banner sup (show childPid) shutdownReason-}+  {-where-}+    {-banner         = "Child Shutdown Complete"-}+    {-shutdownReason = (show reason) ++ ", child-key: " ++ child-}++logExit :: SupervisorPid -> ChildPid -> ExitReason -> Process ()+logExit sup pid er = do+  report $ SupervisedChildDied sup pid er+ logFailure :: SupervisorPid -> ChildPid -> SomeException -> Process () logFailure sup childPid ex = do   logEntry Log.notice $ mkReport "Detected Child Exit" sup (show childPid) (show ex)@@ -1480,7 +1481,7 @@ logEntry lg = Log.report lg Log.logChannel  mkReport :: String -> SupervisorPid -> String -> String -> String-mkReport b s c r = foldl' (\x xs -> xs ++ " " ++ x) "" items+mkReport b s c r = foldl' (\x xs -> xs ++ " " ++ x) "" (reverse items)   where     items :: [String]     items = [ "[" ++ s' ++ "]" | s' <- [ b@@ -1505,14 +1506,14 @@     True  -> Just $ (specs ^= prefix >< remaining) $ st     False -> Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st -{- setChildRestarting :: ChildPid -> Child -> Prefix -> Suffix -> State -> Maybe State setChildRestarting oldPid child prefix remaining st =   let spec   = snd child       newRef = ChildRestarting oldPid   in Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st--} +-- setChildStarted :: ChildPid ->+ doAddChild :: AddChildReq -> Bool -> State -> AddChildRes doAddChild (AddChild _ spec) update st =   let chType = childType spec@@ -1544,7 +1545,7 @@ markActive :: State -> ChildRef -> ChildSpec -> State markActive state ref spec =   case ref of-    ChildRunning (pid :: ChildPid)   -> inserted pid+    ChildRunning (pid :: ChildPid)  -> inserted pid     ChildRunningExtra pid _         -> inserted pid     _                               -> error $ "InternalError"   where@@ -1585,6 +1586,10 @@ restartIntensity :: Accessor RestartStrategy RestartLimit restartIntensity = accessor intensity (\i l -> l { intensity = i }) +-- | The "RestartLimit" for a given "RestartStrategy"+getRestartIntensity :: RestartStrategy -> RestartLimit+getRestartIntensity = (^. restartIntensity)+ restartPeriod :: Accessor State NominalDiffTime restartPeriod = accessor _restartPeriod (\p st -> st { _restartPeriod = p }) @@ -1603,17 +1608,41 @@ children :: Accessor SupervisorStats Int children = accessor _children (\c st -> st { _children = c }) +-- | How many child specs are defined for this supervisor+definedChildren :: SupervisorStats -> Int+definedChildren = (^. children)+ workers :: Accessor SupervisorStats Int workers = accessor _workers (\c st -> st { _workers = c }) -running :: Accessor SupervisorStats Int-running = accessor _running (\r st -> st { _running = r })+-- | How many child specs define a worker (non-supervisor)+definedWorkers :: SupervisorStats -> Int+definedWorkers = (^. workers)  supervisors :: Accessor SupervisorStats Int supervisors = accessor _supervisors (\c st -> st { _supervisors = c }) +-- | How many child specs define a supervisor?+definedSupervisors :: SupervisorStats -> Int+definedSupervisors = (^. supervisors)++running :: Accessor SupervisorStats Int+running = accessor _running (\r st -> st { _running = r })++-- | How many running child processes.+runningChildren :: SupervisorStats -> Int+runningChildren = (^. running)+ activeWorkers :: Accessor SupervisorStats Int activeWorkers = accessor _activeWorkers (\c st -> st { _activeWorkers = c }) +-- | How many worker (non-supervisor) child processes are running.+runningWorkers :: SupervisorStats -> Int+runningWorkers = (^. activeWorkers)+ activeSupervisors :: Accessor SupervisorStats Int activeSupervisors = accessor _activeSupervisors (\c st -> st { _activeSupervisors = c })++-- | How many supervisor child processes are running+runningSupervisors :: SupervisorStats -> Int+runningSupervisors = (^. activeSupervisors)

@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Supervisor.Management+-- 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)+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Supervisor.Management+  ( supervisionAgentId+  , supervisionMonitor+  , monitorSupervisor+  , unmonitorSupervisor+    -- * Mx Event Type+  , MxSupervisor(..)+  )+where+import Control.DeepSeq (NFData)+import Control.Distributed.Process+  ( ProcessId+  , Process()+  , ReceivePort()+  , newChan+  , sendChan+  , getSelfPid+  , unwrapMessage+  )+import Control.Distributed.Process.Internal.Types (SendPort(..))+import Control.Distributed.Process.Management+  ( MxAgentId(..)+  , MxAgent()+  , MxEvent(MxProcessDied, MxUser)+  , mxAgent+  , mxSink+  , mxReady+  , liftMX+  , mxGetLocal+  , mxSetLocal+  , mxNotify+  )+import Control.Distributed.Process.Supervisor.Types+  ( MxSupervisor(..)+  , SupervisorPid+  )+import Data.Binary+import Data.Foldable (mapM_)+import Data.Hashable (Hashable(..))+import Control.Distributed.Process.Extras.Internal.Containers.MultiMap (MultiMap)+import qualified Control.Distributed.Process.Extras.Internal.Containers.MultiMap as Map++import Data.Typeable (Typeable)+import GHC.Generics++data Register = Register !SupervisorPid !ProcessId !(SendPort MxSupervisor)+  deriving (Typeable, Generic)+instance Binary Register where+instance NFData Register where++data UnRegister = UnRegister !SupervisorPid !ProcessId+  deriving (Typeable, Generic)+instance Binary UnRegister where+instance NFData UnRegister where++newtype SupMxChan = SupMxChan { smxc :: SendPort MxSupervisor }+  deriving (Typeable, Generic, Show)+instance Binary SupMxChan+instance NFData SupMxChan+instance Hashable SupMxChan where+  hashWithSalt salt sp = hashWithSalt salt $ sendPortId (smxc sp)+instance Eq SupMxChan where+  (==) a b = (sendPortId $ smxc a) == (sendPortId $ smxc b)++type State = MultiMap SupervisorPid (ProcessId, SupMxChan)++-- | The @MxAgentId@ for the node monitoring agent.+supervisionAgentId :: MxAgentId+supervisionAgentId = MxAgentId "service.monitoring.supervision"++-- | Monitor the supervisor for the given pid. Binds a typed channel to the+-- calling process, to which the resulting @ReceivePort@ belongs.+--+-- Multiple monitors can be created for any @calling process <-> sup@ pair.+-- Each monitor maintains its own typed channel, which will only contain+-- "MxSupervisor" entries obtained /after/ the channel was established.+--+monitorSupervisor :: SupervisorPid -> Process (ReceivePort MxSupervisor)+monitorSupervisor sup = do+  us <- getSelfPid+  (sp, rp) <- newChan+  mxNotify $ Register sup us sp+  return rp++-- | Removes all monitors for @sup@, associated with the calling process.+-- It is not possible to delete individual monitors (i.e. typed channels).+--+unmonitorSupervisor :: SupervisorPid -> Process ()+unmonitorSupervisor sup = getSelfPid >>= mxNotify . UnRegister sup++-- | Starts the supervision monitoring agent.+supervisionMonitor :: Process ProcessId+supervisionMonitor = do+  mxAgent supervisionAgentId initState [+        (mxSink $ \(Register sup pid sp) -> do+          mxSetLocal . Map.insert sup (pid, SupMxChan sp) =<< mxGetLocal+          mxReady)+      , (mxSink $ \(UnRegister sup pid) -> do+          st <- mxGetLocal+          mxSetLocal $ Map.filterWithKey (\k v -> if k == sup then (fst v) /= pid else True) st+          mxReady)+      , (mxSink $ \(ev :: MxEvent) -> do+          case ev of+            MxUser msg          -> goNotify msg >> mxReady+            MxProcessDied pid _ -> do st <- mxGetLocal+                                      mxSetLocal $ Map.filter ((/= pid) . fst) st+                                      mxReady+            _                   -> mxReady)+    ]+  where+    initState :: State+    initState = Map.empty++    goNotify msg = do+      ev <- liftMX $ unwrapMessage msg :: MxAgent State (Maybe MxSupervisor)+      case ev of+        Just ev' -> do st <- mxGetLocal+                       mapM_ (liftMX . (flip sendChan) ev' . smxc . snd)+                             (maybe [] id $ Map.lookup (supervisorPid ev') st)+        Nothing  -> return ()

@@ -11,15 +11,14 @@ -- Portability :  non-portable (requires concurrency) -- ------------------------------------------------------------------------------ module Control.Distributed.Process.Supervisor.Types   ( -- * Defining and Running a Supervisor     ChildSpec(..)   , ChildKey   , ChildType(..)-  , ChildTerminationPolicy(..)+  , ChildStopPolicy(..)   , ChildStart(..)-  , RegisteredName(LocalName, GlobalName, CustomRegister)+  , RegisteredName(LocalName, CustomRegister)   , RestartPolicy(..)   , ChildRef(..)   , isRunning@@ -28,7 +27,6 @@   , StaticLabel   , SupervisorPid   , ChildPid-  , StarterPid     -- * Limits and Defaults   , MaxRestarts(..)   , maxRestarts@@ -46,13 +44,14 @@     -- * Adding and Removing Children   , AddChildResult(..)   , StartChildResult(..)-  , TerminateChildResult(..)+  , StopChildResult(..)   , DeleteChildResult(..)   , RestartChildResult(..)     -- * Additional (Misc) Types   , SupervisorStats(..)   , StartFailure(..)   , ChildInitFailure(..)+  , MxSupervisor(..)   ) where  import GHC.Generics@@ -62,31 +61,41 @@ import Control.DeepSeq (NFData) import Control.Distributed.Process hiding (call) import Control.Distributed.Process.Serializable()+import Control.Distributed.Process.Extras.Internal.Types+  ( ExitReason(..)+  ) import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor) import Control.Exception (Exception)+import Data.Hashable (Hashable)  -- aliases for api documentation purposes++-- | The "ProcessId" of a supervisor. type SupervisorPid = ProcessId++-- | The "ProcessId" of a supervised /child/. type ChildPid = ProcessId-type StarterPid = ProcessId +-- | The maximum number of restarts a supervisor will tollerate, created by+-- evaluating "maxRestarts". newtype MaxRestarts = MaxR { maxNumberOfRestarts :: Int }   deriving (Typeable, Generic, Show) instance Binary MaxRestarts where+instance Hashable MaxRestarts where instance NFData MaxRestarts where --- | Smart constructor for @MaxRestarts@. The maximum--- restart count must be a positive integer.+-- | Smart constructor for @MaxRestarts@. The maximum restart count must be a+-- positive integer, otherwise you will see @error "MaxR must be >= 0"@. maxRestarts :: Int -> MaxRestarts maxRestarts r | r >= 0    = MaxR r               | otherwise = error "MaxR must be >= 0"  -- | A compulsary limit on the number of restarts that a supervisor will--- tolerate before it terminates all child processes and then itself.--- If > @MaxRestarts@ occur within the specified @TimeInterval@, termination--- will occur. This prevents the supervisor from entering an infinite loop of--- child process terminations and restarts.+-- tolerate before it stops all child processes and then itself.+-- If > @MaxRestarts@ occur within the specified @TimeInterval@, the child+-- will be stopped. This prevents the supervisor from entering an infinite loop+-- of child process stops and restarts. -- data RestartLimit =   RestartLimit@@ -97,18 +106,22 @@ instance Binary RestartLimit where instance NFData RestartLimit where +-- | Smart constructor for "RestartLimit". limit :: MaxRestarts -> TimeInterval -> RestartLimit limit mr = RestartLimit mr +-- | Default "RestartLimit" of @MaxR 1@ within @Seconds 1@. defaultLimits :: RestartLimit defaultLimits = limit (MaxR 1) (seconds 1) +-- | Specifies the order in which a supervisor should apply restarts. data RestartOrder = LeftToRight | RightToLeft   deriving (Typeable, Generic, Eq, Show) instance Binary RestartOrder where+instance Hashable RestartOrder where instance NFData RestartOrder where --- TODO: rename these, somehow...+-- | Instructs a supervisor on how to restart its children. data RestartMode =     RestartEach     { order :: !RestartOrder }     {- ^ stop then start each child sequentially, i.e., @foldlM stopThenStart children@ -}@@ -118,12 +131,16 @@     {- ^ stop all children in the given order, but start them in reverse -}   deriving (Typeable, Generic, Show, Eq) instance Binary RestartMode where+instance Hashable RestartMode where instance NFData RestartMode where +-- | Instructs a supervisor on how to instruct its children to stop running+-- when the supervisor itself is shutting down. data ShutdownMode = SequentialShutdown !RestartOrder                       | ParallelShutdown   deriving (Typeable, Generic, Show, Eq) instance Binary ShutdownMode where+instance Hashable ShutdownMode where instance NFData ShutdownMode where  -- | Strategy used by a supervisor to handle child restarts, whether due to@@ -136,9 +153,9 @@ -- 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--- in which siblings are restarted, and to exclude some siblings from the restart+-- siblings, which describe's those children's configured position in insertion+-- order in the child specs. These latter modes allow one to control the order+-- in which siblings are restarted, and to exclude some siblings from restarting, -- without having to resort to grouping them using a child supervisor. -- data RestartStrategy =@@ -207,11 +224,13 @@   ChildStartIgnored      == ChildStartIgnored      = True   _                      == _                      = False +-- | @True@ if "ChildRef" is running. isRunning :: ChildRef -> Bool isRunning (ChildRunning _)        = True isRunning (ChildRunningExtra _ _) = True isRunning _                       = False +-- | @True@ if "ChildRef" is restarting isRestarting :: ChildRef -> Bool isRestarting (ChildRestarting _) = True isRestarting _                   = False@@ -236,26 +255,29 @@ instance Binary ChildType where instance NFData ChildType where --- | Describes when a terminated child process should be restarted.+-- | Describes when a stopped child process should be restarted. 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 stops abnormally   | Intrinsic  -- ^ as 'Transient', but if the child exits normally, the supervisor also exits normally   deriving (Typeable, Generic, Eq, Show) instance Binary RestartPolicy where instance NFData RestartPolicy where -data ChildTerminationPolicy =-    TerminateTimeout !Delay-  | TerminateImmediately+-- | Governs how the supervisor will instruct child processes to stop.+data ChildStopPolicy =+    StopTimeout !Delay+  | StopImmediately   deriving (Typeable, Generic, Eq, Show)-instance Binary ChildTerminationPolicy where-instance NFData ChildTerminationPolicy where+instance Binary ChildStopPolicy where+instance NFData ChildStopPolicy where +-- | Represents a registered name, for registration /locally/ using the+-- @register@ primitive, or via a @Closure (ChildPid -> Process ())@ such that+-- registration can be performed using alternative process registries. data RegisteredName =     LocalName          !String-  | GlobalName         !String   | CustomRegister     !(Closure (ChildPid -> Process ()))   deriving (Typeable, Generic) instance Binary RegisteredName where@@ -264,12 +286,11 @@ instance Show RegisteredName where   show (CustomRegister _) = "Custom Register"   show (LocalName      n) = n-  show (GlobalName     n) = "global::" ++ n +-- | Defines the way in which a child process is to be started. data ChildStart =     RunClosure !(Closure (Process ()))   | CreateHandle !(Closure (SupervisorPid -> Process (ChildPid, Message)))-  | StarterProcess !StarterPid   deriving (Typeable, Generic, Show) instance Binary ChildStart where instance NFData ChildStart  where@@ -280,23 +301,27 @@ -- e.g., if the child is a long running server, this would be the server /loop/, -- as with e.g., @ManagedProces.start@. data ChildSpec = ChildSpec {-    childKey     :: !ChildKey-  , childType    :: !ChildType-  , childRestart :: !RestartPolicy-  , childStop    :: !ChildTerminationPolicy-  , childStart   :: !ChildStart-  , childRegName :: !(Maybe RegisteredName)+    childKey          :: !ChildKey+  , childType         :: !ChildType+  , childRestart      :: !RestartPolicy+  , childRestartDelay :: !(Maybe TimeInterval)+  , childStop         :: !ChildStopPolicy+  , childStart        :: !ChildStart+  , childRegName      :: !(Maybe RegisteredName)   } deriving (Typeable, Generic, Show) instance Binary ChildSpec where instance NFData ChildSpec where -+-- | A child process failure during init will be reported using this datum data ChildInitFailure =-    ChildInitFailure !String-  | ChildInitIgnore+    ChildInitFailure !String -- ^ The init failed with the corresponding message+  | ChildInitIgnore -- ^ The child told the supervisor to ignore its startup procedure   deriving (Typeable, Generic, Show)+instance Binary ChildInitFailure where+instance NFData ChildInitFailure where instance Exception ChildInitFailure where +-- | Statistics about a running supervisor data SupervisorStats = SupervisorStats {     _children          :: Int   , _supervisors       :: Int@@ -310,6 +335,55 @@ instance Binary SupervisorStats where instance NFData SupervisorStats where +-- | Supervisor event data published to the management API+data MxSupervisor =+    SupervisorBranchRestarted+    {+      supervisorPid  :: SupervisorPid+    , childSpecKey   :: ChildKey+    , diedReason     :: DiedReason+    , branchStrategy :: RestartStrategy+    } -- ^ A branch restart took place+  | SupervisedChildRestarting+    { supervisorPid :: SupervisorPid+    , childInScope  :: Maybe ChildPid+    , childSpecKey  :: ChildKey+    , exitReason    :: ExitReason+    } -- ^ A child is being restarted+  | SupervisedChildStarted+    { supervisorPid :: SupervisorPid+    , childRef      :: ChildRef+    , childSpecKey  :: ChildKey+    } -- ^ A child has been started+  | SupervisedChildStartFailure+    { supervisorPid :: SupervisorPid+    , startFailure  :: StartFailure+    , childSpecKey  :: ChildKey+    } -- ^ A child failed to start+  | SupervisedChildDied+    { supervisorPid :: SupervisorPid+    , childPid      :: ChildPid+    , exitReason    :: ExitReason+    } -- ^ A child process death was detected+  | SupervisedChildInitFailed+    { supervisorPid :: SupervisorPid+    , childPid      :: ChildPid+    , initFailure   :: ChildInitFailure+    } -- ^ A child failed during init+  | SupervisedChildStopped+    { supervisorPid :: SupervisorPid+    , childRef      :: ChildRef+    , diedReason    :: DiedReason+    } -- ^ A child has been stopped+  | SupervisorShutdown+    { supervisorPid :: SupervisorPid+    , shutdownMode  :: ShutdownMode+    , exitRason     :: ExitReason+    } -- ^ A supervisor is shutting down+    deriving (Typeable, Generic, Show)+instance Binary MxSupervisor where+instance NFData MxSupervisor where+ -- | Static labels (in the remote table) are strings. type StaticLabel = String @@ -332,39 +406,42 @@ instance Binary DeleteChildResult where instance NFData DeleteChildResult where +-- | A child represented as a @(ChildRef, ChildSpec)@ pair. type Child = (ChildRef, ChildSpec)  -- exported result types of internal APIs +-- | The result of an @addChild@ request. data AddChildResult =-    ChildAdded         !ChildRef-  | ChildFailedToStart !StartFailure+    ChildAdded         !ChildRef  -- ^ The child was added correctly+  | ChildFailedToStart !StartFailure -- ^ The child failed to start   deriving (Typeable, Generic, Show, Eq) instance Binary AddChildResult where instance NFData AddChildResult where +-- | The result of a @startChild@ request. data StartChildResult =-    ChildStartOk        !ChildRef-  | ChildStartFailed    !StartFailure-  | ChildStartUnknownId-  | ChildStartInitIgnored+    ChildStartOk        !ChildRef     -- ^ The child started successfully+  | ChildStartFailed    !StartFailure -- ^ The child failed to start+  | ChildStartUnknownId               -- ^ The child key was not recognised by the supervisor   deriving (Typeable, Generic, Show, Eq) instance Binary StartChildResult where instance NFData StartChildResult where +-- | The result of a @restartChild@ request. data RestartChildResult =-    ChildRestartOk     !ChildRef-  | ChildRestartFailed !StartFailure-  | ChildRestartUnknownId-  | ChildRestartIgnored+    ChildRestartOk     !ChildRef     -- ^ The child restarted successfully+  | ChildRestartFailed !StartFailure -- ^ The child failed to restart+  | ChildRestartUnknownId            -- ^ The child key was not recognised by the supervisor   deriving (Typeable, Generic, Show, Eq)  instance Binary RestartChildResult where instance NFData RestartChildResult where -data TerminateChildResult =-    TerminateChildOk-  | TerminateChildUnknownId+-- | The result of a @stopChild@ request.+data StopChildResult =+    StopChildOk -- ^ The child was stopped successfully+  | StopChildUnknownId -- ^ The child key was not recognised by the supervisor   deriving (Typeable, Generic, Show, Eq)-instance Binary TerminateChildResult where-instance NFData TerminateChildResult where+instance Binary StopChildResult where+instance NFData StopChildResult where

@@ -1,5 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE Rank2Types          #-}  -- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since -- they rely on ordering constraints which the Cloud Haskell runtime does not@@ -15,20 +18,34 @@   ) import qualified Control.Exception as Ex import Control.Exception (throwIO)-import Control.Distributed.Process hiding (call, monitor)+import Control.Distributed.Process hiding (call, monitor, finally) import Control.Distributed.Process.Closure import Control.Distributed.Process.Node import Control.Distributed.Process.Extras.Internal.Types import Control.Distributed.Process.Extras.Internal.Primitives+import Control.Distributed.Process.Extras.SystemLog+  ( LogLevel(Debug)+  , systemLogFile+  , addFormatter+  , debug+  , logChannel+  ) import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Distributed.Process.Supervisor hiding (start, shutdown) import qualified Control.Distributed.Process.Supervisor as Supervisor+import Control.Distributed.Process.Supervisor.Management+  ( MxSupervisor(..)+  , monitorSupervisor+  , unmonitorSupervisor+  , supervisionMonitor+  ) import Control.Distributed.Process.ManagedProcess.Client (shutdown) import Control.Distributed.Process.Serializable()  import Control.Distributed.Static (staticLabel)-import Control.Monad (void, forM_, forM)+import Control.Monad (void, unless, forM_, forM)+import Control.Monad.Catch (finally) import Control.Rematch   ( equalTo   , is@@ -49,11 +66,13 @@ import Test.Framework.Providers.HUnit (testCase) import TestUtils hiding (waitForExit) import qualified Network.Transport as NT++import System.Random (mkStdGen, randomR) -- test utilities  expectedExitReason :: ProcessId -> String expectedExitReason sup = "killed-by=" ++ (show sup) ++-                         ",reason=TerminatedBySupervisor"+                         ",reason=StoppedBySupervisor"  defaultWorker :: ChildStart -> ChildSpec defaultWorker clj =@@ -62,7 +81,8 @@     childKey     = ""   , childType    = Worker   , childRestart = Temporary-  , childStop    = TerminateImmediately+  , childRestartDelay = Nothing+  , childStop    = StopImmediately   , childStart   = clj   , childRegName = Nothing   }@@ -106,15 +126,54 @@  runInTestContext :: LocalNode                  -> MVar ()+                 -> ShutdownMode                  -> RestartStrategy                  -> [ChildSpec]                  -> (ProcessId -> Process ())                  -> Assertion-runInTestContext node lock rs cs proc = do+runInTestContext node lock sm rs cs proc = do   Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do-    sup <- Supervisor.start rs ParallelShutdown cs+    sup <- Supervisor.start rs sm cs     (proc sup) `finally` (exit sup ExitShutdown) +data Context = Context { sup         :: SupervisorPid+                       , sniffer     :: Sniffer+                       , waitTimeout :: TimeInterval+                       , listSize    :: Int+                       , split       :: forall a . ([a] -> ([a], [a]))+                       }+type Sniffer = ReceivePort MxSupervisor++mkRandom :: Int -> Int -> (Int, Int)+mkRandom minListSz maxListSz+  | minListSz > maxListSz = error "nope"+  | minListSz < 20        = mkRandom 20 maxListSz+  | otherwise  =+      let gen = mkStdGen 273846+          (lSz :: Int, gen') = randomR (minListSz, maxListSz) gen+          (sPt :: Int, _)    = randomR (max 3 (round((fromIntegral lSz) / 3.15 :: Double) :: Int), lSz - 3) gen'+      in (lSz, sPt)++randomIshSizes :: (Int, Int)+randomIshSizes = mkRandom 20 1200++runInTestContext' :: LocalNode+                  -> ShutdownMode+                  -> RestartStrategy+                  -> [ChildSpec]+                  -> (Context -> Process ())+                  -> Assertion+runInTestContext' node sm rs cs proc = do+  liftIO $ do+    -- we don't care about real randomness, just about selecting a vaguely+    -- different sizes for each run...+    let (lSz, sPt) = randomIshSizes+    runProcess node $ do+      sup <- Supervisor.start rs sm cs+      sf <- monitorSupervisor sup+      finally (proc $ Context sup sf (seconds 30) lSz (splitAt sPt))+              (exit sup ExitShutdown >> unmonitorSupervisor sup)+ verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () verifyChildWasRestarted key pid sup = do   void $ waitForExit pid@@ -151,21 +210,116 @@   receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')                         (\(ProcessMonitorNotification _ _ dr) -> return dr) ] -drainChildren :: [Child] -> ProcessId -> Process ()-drainChildren children expected = do-  -- Receive all pids then verify they arrived in the correct order.-  -- Any out-of-order messages (such as ProcessMonitorNotification) will-  -- violate the invariant asserted below, and fail the test case-  pids <- forM children $ \_ -> expect :: Process ProcessId-  let first' = head pids-  Just exp' <- resolve expected-  -- however... we do allow for the scheduler and accept `head $ tail pids` in-  -- lieu of the correct result, since when there are multiple senders we have-  -- no causal guarantees-  if first' /= exp'-     then let second' = head $ tail pids in second' `shouldBe` equalTo exp'-     else first' `shouldBe` equalTo exp'+waitForBranchRestartComplete :: Sniffer+                            -> ChildKey+                            -> Process ()+waitForBranchRestartComplete sniff key = do+  debug logChannel $ "waiting for branch restart..."+  aux 10000 sniff Nothing -- `finally` unmonitorSupervisor sup+  where+    aux :: Int -> Sniffer -> Maybe MxSupervisor -> Process ()+    aux n s m+      | n < 1               = liftIO $ assertFailure $ "Never Saw Branch Restarted for " ++ (show key)+      | Just mx <- m+      , SupervisorBranchRestarted{..} <- mx+      , childSpecKey == key = return ()+      | Nothing <- m        = receiveTimeout 100 [ matchChan s return ] >>= aux (n-1) s+      | otherwise           = aux (n-1) s Nothing +verifySingleRestart :: Context+                   -> ChildKey+                   -> Process ()+verifySingleRestart Context{..} key = do+  sleep $ seconds 1+  let t = asTimeout waitTimeout+  mx <- receiveChanTimeout t sniffer+  case mx of+    Just rs@SupervisedChildRestarting{} -> do+      (childSpecKey rs) `shouldBe` equalTo key+      mx' <- receiveChanTimeout t sniffer+      case mx' of+        Just cs@SupervisedChildStarted{} -> do+          (childSpecKey cs) `shouldBe` equalTo key+          debug logChannel $ "restart ok for " ++ (show cs)+        _ -> liftIO $ assertFailure $ " Unexpected Waiting Child Started " ++ (show mx')+    _ -> liftIO $ assertFailure $ "Unexpected Waiting Child Restarted " ++ (show mx)++verifySeqStartOrder :: Context+                    -> [(ChildRef, Child)]+                    -> ChildKey+                    -> Process ()+verifySeqStartOrder Context{..} xs toStop = do+ -- xs == [(oldRef, (ref, spec))] in specified/insertion order+ -- if shutdown is LeftToRight then that's correct, otherwise we+ -- should expect the shutdowns in reverse order+  sleep $ seconds 1+  let t = asTimeout waitTimeout+  forM_ xs $ \(oCr, c@(cr, cs)) -> do+    debug logChannel $ "checking restart " ++ (show c)+    mx <- receiveTimeout t [ matchChan sniffer return ]+    case mx of+      Just SupervisedChildRestarting{..} -> do+        debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)+        childSpecKey `shouldBe` equalTo (childKey cs)+        unless (childSpecKey == toStop) $ do+          Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer+          debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr)+          childRef `shouldBe` equalTo oCr+        mx' <- receiveChanTimeout t sniffer+        case mx' of+          Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+          _                               -> do+            liftIO $ assertFailure $ "After Stopping " ++ (show cs) +++                                     " received unexpected " ++ (show mx)+      _ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx)++verifyStopStartOrder :: Context+                    -> [(ChildRef, Child)]+                    -> [Child]+                    -> ChildKey+                    -> Process ()+verifyStopStartOrder Context{..} xs restarted toStop = do+ -- xs == [(oldRef, (ref, spec))] in specified/insertion order+ -- if shutdown is LeftToRight then that's correct, otherwise we+ -- should expect the shutdowns in reverse order+  sleep $ seconds 1+  let t = asTimeout waitTimeout+  forM_ xs $ \(oCr, c@(_, cs)) -> do+    debug logChannel $ "checking restart " ++ (show c)+    mx <- receiveTimeout t [ matchChan sniffer return ]+    case mx of+      Just SupervisedChildRestarting{..} -> do+        debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)+        childSpecKey `shouldBe` equalTo (childKey cs)+        if childSpecKey /= toStop+          then do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer+                  debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr)+                  -- childRef `shouldBe` equalTo oCr+                  if childRef /= oCr+                    then debug logChannel $ "childRef " ++ (show childRef) ++ " /= " ++ (show oCr)+                    else return ()+          else return ()+      _ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx)++  debug logChannel "checking start order..."+  sleep $ seconds 1+  forM_ restarted $ \(cr, _) -> do+    debug logChannel $ "checking (reverse) start order for " ++ (show cr)+    mx <- receiveTimeout t [ matchChan sniffer return ]+    case mx of+      Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+      _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx)++checkStartupOrder :: Context -> [Child] -> Process ()+checkStartupOrder Context{..} children = do+ -- assert that we saw the startup sequence working...+  forM_ children $ \(cr, _) -> do+    debug logChannel $ "checking " ++ (show cr)+    mx <- receiveTimeout (asTimeout waitTimeout) [ matchChan sniffer return ]+    case mx of+      Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+      _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx)+ exitIgnore :: Process () exitIgnore = liftIO $ throwIO ChildInitIgnore @@ -191,12 +345,32 @@                                _ -> die r)            -} +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++formatMxSupervisor :: Message -> Process (Maybe String)+formatMxSupervisor msg = do+  m <- unwrapMessage msg :: Process (Maybe MxSupervisor)+  case m of+    Nothing -> return Nothing+    Just m' -> return $ Just (show m')+ $(remotable [ 'exitIgnore             , 'noOp             , 'blockIndefinitely             , 'sleepy             , 'obedient-            , 'notifyMe])+            , 'notifyMe+            , 'runCore+            , 'runApp+            , 'formatMxSupervisor ])  -- test cases start here... @@ -211,14 +385,15 @@ sequentialShutdown result = do   (sp, rp) <- newChan   (sg, rg) <- newChan-  core' <- toChildStart $ runCore sp-  app'  <- toChildStart $ runApp sg++  core' <- toChildStart $ $(mkClosure 'runCore) sp+  app'  <- toChildStart $ $(mkClosure 'runApp) sg   let core = (permChild core') { childRegName = Just (LocalName "core")-                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)+                               , childStop = StopTimeout (Delay $ within 2 Seconds)                                , childKey  = "child-1"                                }   let app  = (permChild app')  { childRegName = Just (LocalName "app")-                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)+                               , childStop = StopTimeout (Delay $ within 2 Seconds)                                , childKey  = "child-2"                                } @@ -228,25 +403,9 @@    () <- 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+  res <- receiveChanTimeout (asTimeout $ seconds 5) rp   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)@@ -257,7 +416,6 @@   where     verifyExit :: ProcessId -> Process ()     verifyExit sup = do---      sa <- isProcessAlive sup       child <- lookupChild sup "temp-worker"       case child of         Nothing       -> return () -- the child exited and was removed ok@@ -433,12 +591,20 @@   kill pid "bye bye"   verifyChildWasRestarted (childKey spec) pid sup -transientChildrenExitShutdown :: ChildStart -> ProcessId -> Process ()-transientChildrenExitShutdown cs sup = do+transientChildrenExitShutdown :: ChildStart -> Context -> Process ()+transientChildrenExitShutdown cs Context{..} = do   let spec = transientWorker cs   (ChildAdded ref) <- startNewChild sup spec++  Just _ <- receiveChanTimeout (asTimeout waitTimeout) sniffer :: Process (Maybe MxSupervisor)+   Just pid <- resolve ref+  mRef <- monitor pid   exit pid ExitShutdown+  waitForDown mRef++  mx <- receiveChanTimeout 1000 sniffer :: Process (Maybe MxSupervisor)+  expectThat mx isNothing   verifyChildWasNotRestarted (childKey spec) pid sup  intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()@@ -493,45 +659,44 @@   let spec = transientWorker cs   let key = childKey spec   ChildAdded ref <- startNewChild sup spec-  void $ terminateChild sup key+  void $ stopChild sup key   restarted <- restartChild sup key   sleepFor 500 Millis   Just (ref', _) <- lookupChild sup key   expectThat ref $ isNot $ equalTo ref'   case restarted of     ChildRestartOk (ChildRunning _) -> return ()-    _ -> liftIO $ assertFailure $ "unexpected termination: " ++ (show restarted)+    _ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted) -terminateChildImmediately :: ChildStart -> ProcessId -> Process ()-terminateChildImmediately cs sup = do+stopChildImmediately :: ChildStart -> ProcessId -> Process ()+stopChildImmediately cs sup = do   let spec = tempWorker cs   ChildAdded ref <- startNewChild sup spec --  Just pid <- resolve ref   mRef <- monitor ref-  void $ terminateChild sup (childKey spec)+  void $ stopChild sup (childKey spec)   reason <- waitForDown mRef   expectThat reason $ equalTo $ DiedException (expectedExitReason sup) -terminatingChildExceedsDelay :: ProcessId -> Process ()-terminatingChildExceedsDelay sup = do+stoppingChildExceedsDelay :: ProcessId -> Process ()+stoppingChildExceedsDelay sup = do   let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy)))-             { childStop = TerminateTimeout (Delay $ within 1 Seconds) }+             { childStop = StopTimeout (Delay $ within 500 Millis) }   ChildAdded ref <- startNewChild sup spec -- Just pid <- resolve ref   mRef <- monitor ref-  void $ terminateChild sup (childKey spec)+  void $ stopChild sup (childKey spec)   reason <- waitForDown mRef   expectThat reason $ equalTo $ DiedException (expectedExitReason sup) -terminatingChildObeysDelay :: ProcessId -> Process ()-terminatingChildObeysDelay sup = do+stoppingChildObeysDelay :: ProcessId -> Process ()+stoppingChildObeysDelay sup = do   let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient)))-             { childStop = TerminateTimeout (Delay $ within 1 Seconds) }+             { childStop = StopTimeout (Delay $ within 1 Seconds) }   ChildAdded child <- startNewChild sup spec   Just pid <- resolve child-  testProcessGo pid   void $ monitor pid-  void $ terminateChild sup (childKey spec)+  void $ stopChild sup (childKey spec)   child `shouldExitWith` DiedNormal  restartAfterThreeAttempts ::@@ -551,34 +716,35 @@     [(_, _)] <- listChildren sup     return () -{- delayedRestartAfterThreeAttempts ::-     (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+     (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)   -> Assertion delayedRestartAfterThreeAttempts withSupervisor = do-  let restartPolicy = DelayedRestart Permanent (within 1 Seconds)-  let spec = (permChild $(mkStaticClosure 'blockIndefinitely))-             { childRestart = restartPolicy }-  let strategy = RestartOne $ limit (maxRestarts 2) (seconds 1)-  withSupervisor strategy [spec] $ \sup -> do+  let spec = (permChild $ RunClosure $ $(mkStaticClosure 'blockIndefinitely))+             { childRestartDelay = Just (seconds 3) }+  let strategy = RestartOne $ limit (maxRestarts 2) (seconds 2)+  withSupervisor strategy [spec] $ \ctx@Context{..} -> do     mapM_ (\_ -> do       [(childRef, _)] <- listChildren sup       Just pid <- resolve childRef       ref <- monitor pid       testProcessStop pid       void $ waitForDown ref) [1..3 :: Int]+     Just (ref, _) <- lookupChild sup $ childKey spec     case ref of-      ChildRestarting _ -> return ()+      ChildRestarting _ -> do+        SupervisedChildStarted{..} <- receiveChan sniffer+        childSpecKey `shouldBe` equalTo (childKey spec)       _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref)-    sleep $ seconds 2++    mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int]+     [(ref', _)] <- listChildren sup-    liftIO $ putStrLn $ "it is: " ++ (show ref')     Just pid <- resolve ref'     mRef <- monitor pid     testProcessStop pid     void $ waitForDown mRef--}  permanentChildExceedsRestartsIntensity ::      ChildStart@@ -598,18 +764,18 @@                       DiedException $ "exit-from=" ++ (show sup) ++                                       ",reason=ReachedMaxRestartIntensity" -terminateChildIgnoresSiblings ::+stopChildIgnoresSiblings ::      ChildStart   -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)   -> Assertion-terminateChildIgnoresSiblings cs withSupervisor = do+stopChildIgnoresSiblings cs withSupervisor = do   let templ = permChild cs   let specs = [templ { childKey = (show i) } | i <- [1..3 :: Int]]   withSupervisor restartAll specs $ \sup -> do     let toStop = childKey $ head specs     Just (ref, _) <- lookupChild sup toStop     mRef <- monitor ref-    terminateChild sup toStop+    stopChild sup toStop     waitForDown mRef     children <- listChildren sup     forM_ (tail $ map fst children) $ \cRef -> do@@ -617,48 +783,62 @@  restartAllWithLeftToRightSeqRestarts ::      ChildStart-  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)   -> Assertion restartAllWithLeftToRightSeqRestarts cs withSupervisor = do+  let (sz, _) = randomIshSizes   let templ = permChild cs-  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]-  withSupervisor restartAll specs $ \sup -> do+  let specs = [templ { childKey = (show i) } | i <- [1..sz :: Int]]+  withSupervisor restartAll specs $ \Context{..} -> do     let toStop = childKey $ head specs     Just (ref, _) <- lookupChild sup toStop     children <- listChildren sup     Just pid <- resolve ref     kill pid "goodbye"-    forM_ (map fst children) $ \cRef -> do-      mRef <- monitor cRef-      waitForDown mRef+    forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown     forM_ (map snd children) $ \cSpec -> do       Just (ref', _) <- lookupChild sup (childKey cSpec)       maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'  restartLeftWithLeftToRightSeqRestarts ::      ChildStart-  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)   -> Assertion restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do+  let (lSz, sptSz) = randomIshSizes   let templ = permChild cs-  let specs = [templ { childKey = (show i) } | i <- [1..500 :: Int]]-  withSupervisor restartLeft specs $ \sup -> do-    let (toRestart, _notToRestart) = splitAt 100 specs+  let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]+  withSupervisor restartLeft specs $ \ctx@Context{..} -> do++    children <- listChildren sup+    checkStartupOrder ctx children++    sniff <- monitorSupervisor sup++    let (toRestart, _notToRestart) = splitAt sptSz specs+    let (restarts, survivors) = splitAt sptSz children     let toStop = childKey $ last toRestart     Just (ref, _) <- lookupChild sup toStop     Just pid <- resolve ref-    children <- listChildren sup-    let (children', survivors) = splitAt 100 children     kill pid "goodbye"-    forM_ (map fst children') $ \cRef -> do-      mRef <- monitor cRef-      waitForDown mRef++    forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown++    -- NB: this uses a separate channel to consume the Mx events...+    waitForBranchRestartComplete sniff toStop++    children' <- listChildren sup+    let (restarted', _) = splitAt sptSz children'+    let xs = zip [fst o | o <- restarts] restarted'+    verifySeqStartOrder ctx xs toStop+     forM_ (map snd children') $ \cSpec -> do       Just (ref', _) <- lookupChild sup (childKey cSpec)       maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'+     resolved <- forM (map fst survivors) resolve     let possibleBadRestarts = catMaybes resolved-    r <- receiveTimeout (after 1 Seconds) [+    r <- receiveTimeout (after 5 Seconds) [         match (\(ProcessMonitorNotification _ pid' _) -> do           case (elem pid' possibleBadRestarts) of             True  -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid'@@ -671,15 +851,16 @@   -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)   -> Assertion restartRightWithLeftToRightSeqRestarts cs withSupervisor = do+  let (lSz, sptSz) = mkRandom 150 688   let templ = permChild cs-  let specs = [templ { childKey = (show i) } | i <- [1..50 :: Int]]+  let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]   withSupervisor restartRight specs $ \sup -> do-    let (_notToRestart, toRestart) = splitAt 40 specs+    let (_notToRestart, toRestart) = splitAt sptSz specs     let toStop = childKey $ head toRestart     Just (ref, _) <- lookupChild sup toStop     Just pid <- resolve ref     children <- listChildren sup-    let (survivors, children') = splitAt 40 children+    let (survivors, children') = splitAt sptSz children     kill pid "goodbye"     forM_ (map fst children') $ \cRef -> do       mRef <- monitor cRef@@ -699,9 +880,10 @@  restartAllWithLeftToRightRestarts :: ProcessId -> Process () restartAllWithLeftToRightRestarts sup = do+  let (lSz, _) = randomIshSizes   self <- getSelfPid   let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]   -- add the specs one by one   forM_ specs $ \s -> void $ startNewChild sup s   -- assert that we saw the startup sequence working...@@ -737,107 +919,101 @@       pids <- forM children $ \_ -> expect :: Process ProcessId       forM_ pids ensureProcessIsAlive -restartAllWithRightToLeftSeqRestarts :: ProcessId -> Process ()-restartAllWithRightToLeftSeqRestarts sup = do+restartAllWithRightToLeftSeqRestarts :: Context -> Process ()+restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do   self <- getSelfPid-  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]+   -- add the specs one by one   forM_ specs $ \s -> do     ChildAdded ref <- startNewChild sup s     maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref+   -- assert that we saw the startup sequence working...+  children <- listChildren sup+  checkStartupOrder ctx children++  -- we need this before the restarts occur+  sniff <- monitorSupervisor sup+   let toStop = childKey $ head specs   Just (ref, _) <- lookupChild sup toStop   Just pid <- resolve ref-  children <- listChildren sup-  drainChildren children pid   kill pid "fooboo"+   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst children) $ \cRef -> do-    Just mRef <- monitor cRef-    receiveWait [-        matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)-                (\_ -> return ())-      ]-  -- ensure that both ends of the pids we've seen are in the right order...-  -- in this case, we expect the last child to be the first notification,-  -- since they were started in right to left order+  forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown++  -- NB: this uses a separate channel to consume the Mx events...+  waitForBranchRestartComplete sniff toStop+   children' <- listChildren sup-  let (ref', _) = last children'-  Just pid' <- resolve ref'-  drainChildren children' pid'+  let xs = zip [fst o | o <- children] children'+  verifySeqStartOrder ctx (reverse xs) toStop -expectLeftToRightRestarts :: ProcessId -> Process ()-expectLeftToRightRestarts sup = do-  self <- getSelfPid-  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  forM_ (map snd children') $ \cSpec -> do+    Just (ref', _) <- lookupChild sup (childKey cSpec)+    maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'++expectLeftToRightRestarts :: Context -> Process ()+expectLeftToRightRestarts ctx@Context{..} = do+  let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   -- add the specs one by one-  forM_ specs $ \s -> do-    ChildAdded c <- startNewChild sup s-    Just p <- resolve c-    p' <- expect-    p' `shouldBe` equalTo p+  forM_ specs $ \s -> void $ startNewChild sup s+   -- assert that we saw the startup sequence working...+  children <- listChildren sup+  checkStartupOrder ctx children+   let toStop = childKey $ head specs   Just (ref, _) <- lookupChild sup toStop   Just pid <- resolve ref-  children <- listChildren sup+   -- wait for all the exit signals and ensure they arrive in RightToLeft order   refs <- forM children $ \(ch, _) -> monitor ch >>= \r -> return (ch, r)   kill pid "fooboo"+   initRes <- receiveTimeout                (asTimeout $ seconds 1)                [ matchIf                  (\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs))                  (\sig@(ProcessMonitorNotification _ _ _) -> return sig) ]   expectThat initRes $ isJust+   forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do     (ProcessMonitorNotification ref' _ _) <- expect     if ref' == mRef then (return ()) else (die "unexpected monitor signal")-  -- in this case, we expect the first child to be the first notification,-  -- since they were started in left to right order-  children' <- listChildren sup-  let (ref', _) = head children'-  Just pid' <- resolve ref'-  drainChildren children' pid' -expectRightToLeftRestarts :: ProcessId -> Process ()-expectRightToLeftRestarts sup = do+expectRightToLeftRestarts :: Bool -> Context -> Process ()+expectRightToLeftRestarts rev ctx@Context{..} = do   self <- getSelfPid   let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..10 :: Int]]+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   -- add the specs one by one   forM_ specs $ \s -> do     ChildAdded ref <- startNewChild sup s     maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref++  children <- listChildren sup+  checkStartupOrder ctx children+   -- assert that we saw the startup sequence working...   let toStop = childKey $ head specs   Just (ref, _) <- lookupChild sup toStop   Just pid <- resolve ref-  children <- listChildren sup-  drainChildren children pid-  kill pid "fooboo"+  kill pid "fooboobarbazbub"+   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst children) $ \cRef -> do-    Just mRef <- monitor cRef-    receiveWait [-        matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)-                (\_ -> return ())-        -- we should NOT see *any* process signalling that it has started-        -- whilst waiting for all the children to be terminated-      , match (\(pid' :: ProcessId) -> do-            liftIO $ assertFailure $ "unexpected signal from " ++ (show pid'))-      ]-  -- ensure that both ends of the pids we've seen are in the right order...-  -- in this case, we expect the last child to be the first notification,-  -- since they were started in right to left order-  children' <- listChildren sup-  let (ref', _) = last children'-  Just pid' <- resolve ref'-  drainChildren children' pid'+  forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown +  restarted' <- listChildren sup+  let xs = zip [fst o | o <- children] restarted'+  let xs' = if rev then xs else reverse xs+  -- say $ "xs = " ++ (show [(o, (cr, childKey cs)) | (o, (cr, cs)) <- xs])+  verifyStopStartOrder ctx xs' (reverse restarted') toStop+ restartLeftWhenLeftmostChildDies :: ChildStart -> ProcessId -> Process () restartLeftWhenLeftmostChildDies cs sup = do   let spec = permChild cs@@ -882,158 +1058,134 @@   Just pid2' <- resolve ref3   pid2 `shouldBe` equalTo pid2' -restartLeftWithLeftToRightRestarts :: ProcessId -> Process ()-restartLeftWithLeftToRightRestarts sup = do+restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process ()+restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do   self <- getSelfPid   let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   forM_ specs $ \s -> void $ startNewChild sup s+   -- assert that we saw the startup sequence working...-  let toStart = childKey $ head specs-  Just (ref, _) <- lookupChild sup toStart-  Just pid <- resolve ref   children <- listChildren sup-  drainChildren children pid-  let (toRestart, _) = splitAt 7 specs+  checkStartupOrder ctx children++  let (toRestart, _) = split specs+  let (restarts, _) = split children   let toStop = childKey $ last toRestart   Just (ref', _) <- lookupChild sup toStop   Just stopPid <- resolve ref'   kill stopPid "goodbye"+   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst (fst $ splitAt 7 children)) $ \cRef -> do-    mRef <- monitor cRef-    waitForDown mRef+  forM_ (map fst (fst $ split children)) $ \cRef -> monitor cRef >>= waitForDown+   children' <- listChildren sup-  let (restarted, notRestarted) = splitAt 7 children'-  -- another (technically) unsafe check-  let firstRestart = childKey $ snd $ head restarted-  Just (rRef, _) <- lookupChild sup firstRestart-  Just fPid <- resolve rRef-  drainChildren restarted fPid-  let [c1, c2] = [map fst cs | cs <- [(snd $ splitAt 7 children), notRestarted]]+  let (restarted, notRestarted) = split children'+  let restarted' = if rev then reverse restarted else restarted+  let restarts'  = if rev then reverse restarts  else restarts+  let xs = zip [fst o | o <- restarts'] restarted'+  verifyStopStartOrder ctx xs restarted toStop++  let [c1, c2] = [map fst cs | cs <- [(snd $ split children), notRestarted]]   forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 -restartRightWithLeftToRightRestarts :: ProcessId -> Process ()-restartRightWithLeftToRightRestarts sup = do-  self <- getSelfPid-  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+restartRightWithLeftToRightRestarts :: Bool -> Context -> Process ()+restartRightWithLeftToRightRestarts rev ctx@Context{..} = do++  let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   forM_ specs $ \s -> void $ startNewChild sup s-  -- assert that we saw the startup sequence working...-  let toStart = childKey $ head specs-  Just (ref, _) <- lookupChild sup toStart-  Just pid <- resolve ref+   children <- listChildren sup-  drainChildren children pid-  let (_, toRestart) = splitAt 3 specs++  -- assert that we saw the startup sequence working...+  checkStartupOrder ctx children++  let (_, toRestart) = split specs+  let (_, restarts) = split children   let toStop = childKey $ head toRestart   Just (ref', _) <- lookupChild sup toStop   Just stopPid <- resolve ref'   kill stopPid "goodbye"   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst (snd $ splitAt 3 children)) $ \cRef -> do-    mRef <- monitor cRef-    waitForDown mRef+  forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown+   children' <- listChildren sup-  let (notRestarted, restarted) = splitAt 3 children'-  -- another (technically) unsafe check-  let firstRestart = childKey $ snd $ head restarted-  Just (rRef, _) <- lookupChild sup firstRestart-  Just fPid <- resolve rRef-  drainChildren restarted fPid+  let (notRestarted, restarted) = split children'++  let restarted' = if rev then reverse restarted else restarted+  let restarts'  = if rev then reverse restarts  else restarts+  let xs = zip [fst o | o <- restarts'] restarted'+  verifyStopStartOrder ctx xs restarted toStop+   let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]]   forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 -restartRightWithRightToLeftRestarts :: ProcessId -> Process ()-restartRightWithRightToLeftRestarts sup = do-  self <- getSelfPid-  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+restartRightWithRightToLeftRestarts :: Bool -> Context -> Process ()+restartRightWithRightToLeftRestarts rev ctx@Context{..} = do+  let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   forM_ specs $ \s -> void $ startNewChild sup s-  -- assert that we saw the startup sequence working...-  let toStart = childKey $ head specs-  Just (ref, _) <- lookupChild sup toStart-  Just pid <- resolve ref+   children <- listChildren sup-  drainChildren children pid-  let (_, toRestart) = splitAt 3 specs++  -- assert that we saw the startup sequence working...+  checkStartupOrder ctx children++  let (_, toRestart) = split specs+  let (_, restarts) = split children   let toStop = childKey $ head toRestart   Just (ref', _) <- lookupChild sup toStop   Just stopPid <- resolve ref'   kill stopPid "goodbye"+   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst (snd $ splitAt 3 children)) $ \cRef -> do-    mRef <- monitor cRef-    waitForDown mRef+  forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown+   children' <- listChildren sup-  let (notRestarted, restarted) = splitAt 3 children'-  -- another (technically) unsafe check-  let firstRestart = childKey $ snd $ last restarted-  Just (rRef, _) <- lookupChild sup firstRestart-  Just fPid <- resolve rRef-  drainChildren restarted fPid-  let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]]+  let (notRestarted, restarted) = split children'++  let (restarts', restarted') = if rev then (reverse restarts, reverse restarted)+                                       else (restarts, restarted)+  let xs = zip [fst o | o <- restarts'] restarted'+  verifyStopStartOrder ctx xs (reverse restarted) toStop++  let [c1, c2] = [map fst cs | cs <- [(fst $ split children), notRestarted]]   forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 -restartLeftWithRightToLeftRestarts :: ProcessId -> Process ()-restartLeftWithRightToLeftRestarts sup = do-  self <- getSelfPid-  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)-  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process ()+restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do+  let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)+  let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]   forM_ specs $ \s -> void $ startNewChild sup s-  -- assert that we saw the startup sequence working...-  let toStart = childKey $ head specs-  Just (ref, _) <- lookupChild sup toStart-  Just pid <- resolve ref+   children <- listChildren sup-  drainChildren children pid-  let (toRestart, _) = splitAt 7 specs-  let (restarts, toSurvive) = splitAt 7 children++  -- assert that we saw the startup sequence working...+  checkStartupOrder ctx children++  -- split off 6 children to be restarted+  let (toRestart, _) = split specs+  let (restarts, toSurvive) = split children   let toStop = childKey $ last toRestart   Just (ref', _) <- lookupChild sup toStop   Just stopPid <- resolve ref'-  kill stopPid "goodbye"+  kill stopPid "test process waves goodbye...."+   -- wait for all the exit signals, so we know the children are restarting-  forM_ (map fst restarts) $ \cRef -> do-    mRef <- monitor cRef-    waitForDown mRef-  children' <- listChildren sup-  let (restarted, notRestarted) = splitAt 7 children'-  -- another (technically) unsafe check-  let firstRestart = childKey $ snd $ last restarted-  Just (rRef, _) <- lookupChild sup firstRestart-  Just fPid <- resolve rRef-  drainChildren (reverse restarted) fPid-  let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]]-  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2+  forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown -localChildStartLinking :: TestResult Bool -> Process ()-localChildStartLinking result = do-    s1 <- toChildStart procExpect-    s2 <- toChildStart procLinkExpect-    pid <- Supervisor.start restartOne ParallelShutdown [ (tempWorker s1) { childKey = "w1" }-                                                        , (tempWorker s2) { childKey = "w2" } ]-    [(r1, _), (r2, _)] <- listChildren pid-    Just p1 <- resolve r1-    Just p2 <- resolve r2-    monitor p1-    monitor p2-    shutdownAndWait pid-    waitForChildShutdown [p1, p2]-    stash result True-  where-    procExpect :: Process ()-    procExpect = expect >>= return+  children' <- listChildren sup+  let (restarted, notRestarted) = split children'+  --let xs = zip [fst o | o <- restarts] restarted+  let (restarts', restarted') = if rev then (reverse restarts, reverse restarted)+                                       else (restarts, restarted)+  let xs = zip [fst o | o <- restarts'] restarted' -    procLinkExpect :: SupervisorPid -> Process ProcessId-    procLinkExpect p = spawnLocal $ link p >> procExpect+  verifyStopStartOrder ctx xs (reverse restarted) toStop -    waitForChildShutdown []   = return ()-    waitForChildShutdown pids = do-      p <- receiveWait [-               match (\(ProcessMonitorNotification _ p _) -> return p)-             ]-      waitForChildShutdown $ filter (/= p) pids+  let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]]+  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2  -- remote table definition and main @@ -1047,21 +1199,31 @@   cs <- toChildStart clj   fn cs supervisor -withChan :: (ChildStart -> ProcessId -> Process ())-         -> Process ()-         -> ProcessId-         -> Process ()-withChan fn proc supervisor = do-    cs <- toChildStart proc-    fn cs supervisor+withClosure' :: (ChildStart -> Context -> Process ())+             -> (Closure (Process ()))+             -> Context+             -> Process ()+withClosure' fn clj ctx = do+  cs <- toChildStart clj+  fn cs ctx  tests :: NT.Transport -> IO [Test] tests transport = do   putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) "-                    , "Can Fail Intermittently"]+                    , "Can Fail Intermittently" ]   localNode <- newLocalNode transport myRemoteTable   singleTestLock <- newMVar ()-  let withSupervisor = runInTestContext localNode singleTestLock+  runProcess localNode $ do+    void $ supervisionMonitor+    {-+    slog <- systemLogFile "supervisor.test.log" Debug return+    addFormatter slog $(mkStaticClosure 'formatMxSupervisor)+    -}+  +  let withSup sm = runInTestContext localNode singleTestLock sm+  let withSup' sm = runInTestContext' localNode sm+  let withSupervisor = runInTestContext localNode singleTestLock ParallelShutdown+  let withSupervisor' = runInTestContext' localNode ParallelShutdown   return     [ testGroup "Supervisor Processes"       [@@ -1069,74 +1231,47 @@           [               testCase "Normal (Managed Process) Supervisor Start Stop"                 (withSupervisor restartOne [] normalStartStop)-            , testGroup "Specified By Closure"-              [-                testCase "Add Child Without Starting"-                    (withSupervisor restartOne []-                          (withClosure addChildWithoutRestart-                           $(mkStaticClosure 'blockIndefinitely)))-              , testCase "Start Previously Added Child"-                    (withSupervisor restartOne []-                          (withClosure addChildThenStart-                           $(mkStaticClosure 'blockIndefinitely)))-              , testCase "Start Unknown Child"-                    (withSupervisor restartOne []-                          (withClosure startUnknownChild-                           $(mkStaticClosure 'blockIndefinitely)))-              , testCase "Add Duplicate Child"-                    (withSupervisor restartOne []-                          (withClosure addDuplicateChild-                             $(mkStaticClosure 'blockIndefinitely)))-              , testCase "Start Duplicate Child"-                    (withSupervisor restartOne []-                          (withClosure startDuplicateChild-                             $(mkStaticClosure 'blockIndefinitely)))-              , testCase "Started Temporary Child Exits With Ignore"-                    (withSupervisor restartOne []-                          (withClosure startTemporaryChildExitsWithIgnore-                             $(mkStaticClosure 'exitIgnore)))-              , testCase "Configured Temporary Child Exits With Ignore"-                    (configuredTemporaryChildExitsWithIgnore-                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)-              , testCase "Start Bad Closure"-                    (withSupervisor restartOne []-                     (withClosure startBadClosure-                      (closure (staticLabel "non-existing") empty)))-              , testCase "Configured Bad Closure"-                    (configuredTemporaryChildExitsWithIgnore-                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)-              , testCase "Started Non-Temporary Child Exits With Ignore"-                    (withSupervisor restartOne [] $-                     (withClosure startNonTemporaryChildExitsWithIgnore-                      $(mkStaticClosure 'exitIgnore)))-              , testCase "Configured Non-Temporary Child Exits With Ignore"-                    (configuredNonTemporaryChildExitsWithIgnore-                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)-              ]-            , testGroup "Specified By Delegate/Restarter"-              [-                testCase "Add Child Without Starting (Chan)"+            , testCase "Add Child Without Starting"                   (withSupervisor restartOne []-                   (withChan addChildWithoutRestart blockIndefinitely))-              , testCase "Start Previously Added Child"+                        (withClosure addChildWithoutRestart+                         $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Start Previously Added Child"                   (withSupervisor restartOne []-                   (withChan addChildThenStart blockIndefinitely))-              , testCase "Start Unknown Child"+                        (withClosure addChildThenStart+                         $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Start Unknown Child"                   (withSupervisor restartOne []-                   (withChan startUnknownChild blockIndefinitely))-              , testCase "Add Duplicate Child (Chan)"+                        (withClosure startUnknownChild+                         $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Add Duplicate Child"                   (withSupervisor restartOne []-                   (withChan addDuplicateChild blockIndefinitely))-              , testCase "Start Duplicate Child (Chan)"+                        (withClosure addDuplicateChild+                           $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Start Duplicate Child"                   (withSupervisor restartOne []-                   (withChan startDuplicateChild blockIndefinitely))-              , testCase "Started Temporary Child Exits With Ignore (Chan)"+                        (withClosure startDuplicateChild+                           $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Started Temporary Child Exits With Ignore"                   (withSupervisor restartOne []-                   (withChan startTemporaryChildExitsWithIgnore exitIgnore))-              , testCase "Started Non-Temporary Child Exits With Ignore (Chan)"+                        (withClosure startTemporaryChildExitsWithIgnore+                           $(mkStaticClosure 'exitIgnore)))+            , testCase "Configured Temporary Child Exits With Ignore"+                  (configuredTemporaryChildExitsWithIgnore+                   (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)+            , testCase "Start Bad Closure"+                  (withSupervisor restartOne []+                   (withClosure startBadClosure+                    (closure (staticLabel "non-existing") empty)))+            , testCase "Configured Bad Closure"+                  (configuredTemporaryChildExitsWithIgnore+                   (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)+            , testCase "Started Non-Temporary Child Exits With Ignore"                   (withSupervisor restartOne [] $-                   (withChan startNonTemporaryChildExitsWithIgnore exitIgnore))-              ]+                   (withClosure startNonTemporaryChildExitsWithIgnore+                    $(mkStaticClosure 'exitIgnore)))+            , testCase "Configured Non-Temporary Child Exits With Ignore"+                  (configuredNonTemporaryChildExitsWithIgnore+                   (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)           ]         , testGroup "Stopping And Deleting Children"           [@@ -1167,122 +1302,93 @@                 (withSupervisor restartOne []                     (withClosure permanentChildrenAlwaysRestart                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Permanent Children Always Restart (Chan)"-                (withSupervisor restartOne []-                    (withChan permanentChildrenAlwaysRestart blockIndefinitely))           , testCase "Temporary Children Never Restart (Closure)"                 (withSupervisor restartOne []                     (withClosure temporaryChildrenNeverRestart                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Temporary Children Never Restart (Chan)"-                (withSupervisor restartOne []-                    (withChan temporaryChildrenNeverRestart blockIndefinitely))           , testCase "Transient Children Do Not Restart When Exiting Normally (Closure)"                 (withSupervisor restartOne []                     (withClosure transientChildrenNormalExit                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Transient Children Do Not Restart When Exiting Normally (Chan)"-                (withSupervisor restartOne []-                    (withChan transientChildrenNormalExit blockIndefinitely))           , testCase "Transient Children Do Restart When Exiting Abnormally (Closure)"                 (withSupervisor restartOne []                     (withClosure transientChildrenAbnormalExit                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Transient Children Do Restart When Exiting Abnormally (Chan)"-                (withSupervisor restartOne []-                    (withChan transientChildrenAbnormalExit blockIndefinitely))-          , testCase "ExitShutdown Is Considered Normal (Closure)"-                (withSupervisor restartOne []-                    (withClosure transientChildrenExitShutdown+          , testCase "ExitShutdown Is Considered Normal"+                (withSupervisor' restartOne []+                    (withClosure' transientChildrenExitShutdown                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "ExitShutdown Is Considered Normal (Chan)"-                (withSupervisor restartOne []-                    (withChan transientChildrenExitShutdown blockIndefinitely))           , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)"                 (withSupervisor restartOne []                     (withClosure intrinsicChildrenAbnormalExit                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Chan)"-                (withSupervisor restartOne []-                    (withChan intrinsicChildrenAbnormalExit blockIndefinitely))           , testCase (concat [ "Intrinsic Children Cause Supervisor Exits "                              , "When Exiting Normally (Closure)"])                 (withSupervisor restartOne []                     (withClosure intrinsicChildrenNormalExit                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase (concat [ "Intrinsic Children Cause Supervisor Exits "-                             , "When Exiting Normally (Chan)"])-                (withSupervisor restartOne []-                    (withChan intrinsicChildrenNormalExit blockIndefinitely))           , testCase "Explicit Restart Of Running Child Fails (Closure)"                 (withSupervisor restartOne []                     (withClosure explicitRestartRunningChild                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Explicit Restart Of Running Child Fails (Chan)"-                (withSupervisor restartOne []-                    (withChan explicitRestartRunningChild blockIndefinitely))           , testCase "Explicit Restart Of Unknown Child Fails"                 (withSupervisor restartOne [] explicitRestartUnknownChild)           , testCase "Explicit Restart Whilst Child Restarting Fails (Closure)"                 (withSupervisor                  (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) []                  (withClosure explicitRestartRestartingChild $(mkStaticClosure 'noOp)))-          , testCase "Explicit Restart Whilst Child Restarting Fails (Chan)"-                (withSupervisor-                 (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) []-                 (withChan explicitRestartRestartingChild noOp))           , testCase "Explicit Restart Stopped Child (Closure)"                 (withSupervisor restartOne []                     (withClosure explicitRestartStoppedChild                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Explicit Restart Stopped Child (Chan)"-                (withSupervisor restartOne []-                    (withChan explicitRestartStoppedChild blockIndefinitely))-          , testCase "Immediate Child Termination (Brutal Kill) (Closure)"+          , testCase "Immediate Child Stop (Brutal Kill) (Closure)"                 (withSupervisor restartOne []-                    (withClosure terminateChildImmediately+                    (withClosure stopChildImmediately                                  $(mkStaticClosure 'blockIndefinitely)))-          , testCase "Immediate Child Termination (Brutal Kill) (Chan)"-                (withSupervisor restartOne []-                    (withChan terminateChildImmediately blockIndefinitely))-          -- TODO: Chan tests-          , testCase "Child Termination Exceeds Timeout/Delay (Becomes Brutal Kill)"-                (withSupervisor restartOne [] terminatingChildExceedsDelay)-          , testCase "Child Termination Within Timeout/Delay"-                (withSupervisor restartOne [] terminatingChildObeysDelay)+          , testCase "Child Stop Exceeds Timeout/Delay (Becomes Brutal Kill)"+                (withSupervisor restartOne [] stoppingChildExceedsDelay)+          , testCase "Child Stop Within Timeout/Delay"+                (withSupervisor restartOne [] stoppingChildObeysDelay)           ]           -- TODO: test for init failures (expecting $ ChildInitFailed r)         , testGroup "Branch Restarts"           [             testGroup "Restart All"             [-              testCase "Terminate Child Ignores Siblings"-                  (terminateChildIgnoresSiblings+              testCase "Stop Child Ignores Siblings"+                  (stopChildIgnoresSiblings                    (RunClosure $(mkStaticClosure 'blockIndefinitely))                    withSupervisor)             , testCase "Restart All, Left To Right (Sequential) Restarts"                   (restartAllWithLeftToRightSeqRestarts                    (RunClosure $(mkStaticClosure 'blockIndefinitely))-                   withSupervisor)+                   withSupervisor')             , testCase "Restart All, Right To Left (Sequential) Restarts"-                  (withSupervisor+                  (withSupervisor'                    (RestartAll defaultLimits (RestartEach RightToLeft)) []                     restartAllWithRightToLeftSeqRestarts)             , testCase "Restart All, Left To Right Stop, Left To Right Start"-                  (withSupervisor+                  (withSup+                   (SequentialShutdown LeftToRight)                    (RestartAll defaultLimits (RestartInOrder LeftToRight)) []                     restartAllWithLeftToRightRestarts)             , testCase "Restart All, Right To Left Stop, Right To Left Start"-                  (withSupervisor-                   (RestartAll defaultLimits (RestartInOrder RightToLeft)) []-                    expectRightToLeftRestarts)+                  (withSup'+                   (SequentialShutdown RightToLeft)+                   (RestartAll defaultLimits (RestartInOrder RightToLeft)+                   ) []+                    (expectRightToLeftRestarts False))             , testCase "Restart All, Left To Right Stop, Reverse Start"-                  (withSupervisor-                   (RestartAll defaultLimits (RestartRevOrder LeftToRight)) []-                    expectRightToLeftRestarts)+                  (withSup'+                   (SequentialShutdown LeftToRight)+                   (RestartAll defaultLimits (RestartRevOrder LeftToRight)+                    ) []+                    (expectRightToLeftRestarts True))             , testCase "Restart All, Right To Left Stop, Reverse Start"-                  (withSupervisor-                   (RestartAll defaultLimits (RestartRevOrder RightToLeft)) []+                  (withSup'+                   (SequentialShutdown RightToLeft)+                   (RestartAll defaultLimits (RestartRevOrder RightToLeft)+                    ) []                     expectLeftToRightRestarts)             ],             testGroup "Restart Left"@@ -1290,27 +1396,27 @@               testCase "Restart Left, Left To Right (Sequential) Restarts"                   (restartLeftWithLeftToRightSeqRestarts                    (RunClosure $(mkStaticClosure 'blockIndefinitely))-                   withSupervisor)+                   withSupervisor')             , testCase "Restart Left, Leftmost Child Dies"                   (withSupervisor restartLeft [] $                     restartLeftWhenLeftmostChildDies                     (RunClosure $(mkStaticClosure 'blockIndefinitely)))             , testCase "Restart Left, Left To Right Stop, Left To Right Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartLeft defaultLimits (RestartInOrder LeftToRight)) []-                    restartLeftWithLeftToRightRestarts)+                    (restartLeftWithLeftToRightRestarts False))             , testCase "Restart Left, Right To Left Stop, Right To Left Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartLeft defaultLimits (RestartInOrder RightToLeft)) []-                    restartLeftWithRightToLeftRestarts)+                    (restartLeftWithRightToLeftRestarts True))             , testCase "Restart Left, Left To Right Stop, Reverse Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartLeft defaultLimits (RestartRevOrder LeftToRight)) []-                    restartLeftWithRightToLeftRestarts)+                    (restartLeftWithRightToLeftRestarts False))             , testCase "Restart Left, Right To Left Stop, Reverse Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartLeft defaultLimits (RestartRevOrder RightToLeft)) []-                    restartLeftWithLeftToRightRestarts)+                    (restartLeftWithLeftToRightRestarts True))             ],             testGroup "Restart Right"             [@@ -1323,23 +1429,23 @@                     restartRightWhenRightmostChildDies                     (RunClosure $(mkStaticClosure 'blockIndefinitely)))             , testCase "Restart Right, Left To Right Stop, Left To Right Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartRight defaultLimits (RestartInOrder LeftToRight)) []-                    restartRightWithLeftToRightRestarts)+                    (restartRightWithLeftToRightRestarts False))             , testCase "Restart Right, Right To Left Stop, Right To Left Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartRight defaultLimits (RestartInOrder RightToLeft)) []-                    restartRightWithRightToLeftRestarts)+                    (restartRightWithRightToLeftRestarts True))             , testCase "Restart Right, Left To Right Stop, Reverse Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartRight defaultLimits (RestartRevOrder LeftToRight)) []-                    restartRightWithRightToLeftRestarts)+                    (restartRightWithRightToLeftRestarts False))             , testCase "Restart Right, Right To Left Stop, Reverse Start"-                  (withSupervisor+                  (withSupervisor'                    (RestartRight defaultLimits (RestartRevOrder RightToLeft)) []-                    restartRightWithLeftToRightRestarts)-            ]+                    (restartRightWithLeftToRightRestarts True))             ]+          ]         , testGroup "Restart Intensity"           [             testCase "Three Attempts Before Successful Restart"@@ -1348,19 +1454,18 @@           , testCase "Permanent Child Exceeds Restart Limits"                 (permanentChildExceedsRestartsIntensity                  (RunClosure $(mkStaticClosure 'noOp)) withSupervisor)---          , testCase "Permanent Child Delayed Restart"---                (delayedRestartAfterThreeAttempts withSupervisor)-          ]-        , testGroup "ToChildStart Link Setup"-          [-            testCase "Both Local Process Instances Link Appropriately"-             (delayedAssertion-              "expected the server to return the task outcome"-              localNode True localChildStartLinking)+          , testCase "Permanent Child Delayed Restart"+                (delayedRestartAfterThreeAttempts withSupervisor')           ]       ]+{-    , testGroup "CI"+      [ testCase "Flush [NonTest]"+        (withSupervisor'+          (RestartRight defaultLimits (RestartInOrder LeftToRight)) []+           (\_ -> sleep $ seconds 20))+      ]+-}     ]  main :: IO () main = testMain $ tests-

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE DeriveGeneric             #-} @@ -56,7 +57,7 @@   , putMVar   ) -import Control.Distributed.Process+import Control.Distributed.Process hiding (catch, finally) import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable() import Control.Distributed.Process.Extras.Time@@ -65,6 +66,7 @@ import Control.Exception (SomeException) import qualified Control.Exception as Exception import Control.Monad (forever)+import Control.Monad.Catch (catch) import Control.Monad.STM (atomically) import Control.Rematch hiding (match) import Control.Rematch.Run@@ -101,7 +103,7 @@ shouldMatch :: a -> Matcher a -> Process () shouldMatch = expectThat -shouldExitWith :: (Addressable a) => a -> DiedReason -> Process ()+shouldExitWith :: (Resolvable a) => a -> DiedReason -> Process () shouldExitWith a r = do   _ <- resolve a   d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ]@@ -121,8 +123,8 @@  mkNode :: String -> IO LocalNode mkNode port = do-  Right (transport1, _) <- createTransportExposeInternals-                                    "127.0.0.1" port defaultTCPParameters+  Right (transport1, _) <-+    createTransportExposeInternals "127.0.0.1" port ("127.0.0.1",) defaultTCPParameters   newLocalNode transport1 initRemoteTable  -- | Run the supplied @testProc@ using an @MVar@ to collect and assert@@ -168,7 +170,7 @@ testMain :: (NT.Transport -> IO [Test]) -> IO () testMain builder = do   Right (transport, _) <- createTransportExposeInternals-                                    "127.0.0.1" "0" defaultTCPParameters+                                    "127.0.0.1" "0" ("127.0.0.1",) defaultTCPParameters   testData <- builder transport   defaultMain testData