diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2018-06-14 Facundo Domínguez 0.2.1 + +* Update dependency bounds. + 2016-02-16 Facundo Domínguez 0.1.3.2 * Update dependency bounds. diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/distributed-process-supervisor.cabal b/distributed-process-supervisor.cabal --- a/distributed-process-supervisor.cabal +++ b/distributed-process-supervisor.cabal @@ -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 +Maintainer: Tim Watson 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 diff --git a/src/Control/Distributed/Process/Supervisor.hs b/src/Control/Distributed/Process/Supervisor.hs --- a/src/Control/Distributed/Process/Supervisor.hs +++ b/src/Control/Distributed/Process/Supervisor.hs @@ -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) diff --git a/src/Control/Distributed/Process/Supervisor/Management.hs b/src/Control/Distributed/Process/Supervisor/Management.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Supervisor/Management.hs @@ -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 +-- 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 () diff --git a/src/Control/Distributed/Process/Supervisor/Types.hs b/src/Control/Distributed/Process/Supervisor/Types.hs --- a/src/Control/Distributed/Process/Supervisor/Types.hs +++ b/src/Control/Distributed/Process/Supervisor/Types.hs @@ -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 diff --git a/tests/TestSupervisor.hs b/tests/TestSupervisor.hs --- a/tests/TestSupervisor.hs +++ b/tests/TestSupervisor.hs @@ -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 - diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -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