diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2025-02-04 Laurent P. René de Cotret 0.2.4 + +* Ported test suite to use `tasty` rather than `test-framework`. +* Addressed some compilation warnings (#467). + +2024-09-03 Laurent P. René de Cotret 0.2.2 + +* Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1 +* Updated links to point to Distributed Haskell monorepo + +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/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/distributed-process-supervisor.cabal b/distributed-process-supervisor.cabal --- a/distributed-process-supervisor.cabal +++ b/distributed-process-supervisor.cabal @@ -1,16 +1,15 @@ +cabal-version: 3.0 name: distributed-process-supervisor -version: 0.1.3.2 -cabal-version: >=1.8 +version: 0.2.4 build-type: Simple -license: BSD3 -license-file: LICENCE -stability: experimental +license: BSD-3-Clause +license-file: LICENSE Copyright: Tim Watson 2012 - 2013 Author: Tim Watson -Maintainer: Facundo Domínguez +maintainer: The Distributed Haskell team Stability: experimental -Homepage: http://github.com/haskell-distributed/distributed-process-supervisor -Bug-Reports: http://github.com/haskell-distributed/distributed-process-supervisor/issues +Homepage: http://github.com/haskell-distributed/distributed-process +Bug-Reports: http://github.com/haskell-distributed/distributed-process/issues synopsis: Supervisors for The Cloud Haskell Application Platform description: A part of the Cloud Haskell framework @@ -21,77 +20,98 @@ For detailed information see "Control.Distributed.Process.Supervisor" category: Control -tested-with: GHC == 7.4.2 GHC == 7.6.2 -data-dir: "" -extra-source-files: ChangeLog +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 GHC==9.12.1 +extra-doc-files: ChangeLog source-repository head - type: git - location: https://github.com/haskell-distributed/distributed-process-supervisor + Type: git + Location: https://github.com/haskell-distributed/distributed-process + SubDir: packages/distributed-process-supervisor +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + -Wunused-packages + library + import: warnings build-depends: - base >= 4.4 && < 5, + base >= 4.14 && < 5, 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, - deepseq >= 1.3.0.1 && < 1.5, - mtl, - containers >= 0.4 && < 0.6, - hashable >= 1.2.0.5 && < 1.3, - 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 - extensions: CPP + 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.8 && < 0.9, + deepseq >= 1.4 && < 1.7, + containers >= 0.6 && < 0.8, + hashable >= 1.2.0.5 && < 1.6, + time > 1.4 && < 1.15, + exceptions >= 0.10 && < 0.11 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 + default-language: Haskell2010 test-suite SupervisorTests + import: warnings type: exitcode-stdio-1.0 build-depends: - base >= 4.4 && < 5, - ansi-terminal >= 0.5 && < 0.7, - containers, - unordered-containers, - hashable, - distributed-process >= 0.5.3 && < 0.7, + base >= 4.14 && < 5, + distributed-static >= 0.3.5.0 && < 0.4, + distributed-process >= 0.7.3 && < 0.8, distributed-process-supervisor, - distributed-process-extras, + distributed-process-extras >= 0.3 && < 0.4, distributed-process-client-server, distributed-static, bytestring, - data-accessor, - fingertree < 0.2, - network-transport >= 0.4 && < 0.5, - mtl, - network-transport-tcp >= 0.4 && < 0.6, - binary >= 0.6.3.0 && < 0.8, - 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, - test-framework >= 0.6 && < 0.9, - test-framework-hunit, - transformers, - rematch >= 0.2.0.0, - ghc-prim - hs-source-dirs: - tests - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog - extensions: CPP + random, + network-transport >= 0.4 && < 0.6, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + stm, + tasty >= 1.5 && <1.6, + tasty-hunit >=0.10 && <0.11, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind main-is: TestSupervisor.hs other-modules: TestUtils + default-language: Haskell2010 + +test-suite NonThreadedSupervisorTests + import: warnings + type: exitcode-stdio-1.0 + build-depends: + base >= 4.14 && < 5, + bytestring, + 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, + random, + network-transport, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + stm, + tasty >= 1.5 && <1.6, + tasty-hunit >=0.10 && <0.11, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: tests + ghc-options: -rtsopts -fno-warn-unused-do-bind -fno-warn-name-shadowing + main-is: TestSupervisor.hs + other-modules: TestUtils + default-language: Haskell2010 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 @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} @@ -6,7 +7,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverlappingInstances #-} ----------------------------------------------------------------------------- -- | @@ -25,26 +25,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 +47,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 +136,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 +147,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 +214,7 @@ ChildSpec(..) , ChildKey , ChildType(..) - , ChildTerminationPolicy(..) + , ChildStopPolicy(..) , ChildStart(..) , RegisteredName(LocalName, CustomRegister) , RestartPolicy(..) @@ -228,7 +226,6 @@ , StaticLabel , SupervisorPid , ChildPid - , StarterPid , ToChildStart(..) , start , run @@ -252,8 +249,8 @@ , StartChildResult(..) , startChild , startNewChild - , terminateChild - , TerminateChildResult(..) + , stopChild + , StopChildResult(..) , deleteChild , DeleteChildResult(..) , restartChild @@ -266,6 +263,13 @@ , listChildren , SupervisorStats(..) , statistics + , getRestartIntensity + , definedChildren + , definedWorkers + , definedSupervisors + , runningChildren + , runningWorkers + , runningSupervisors -- * Additional (Misc) Types , StartFailure(..) , ChildInitFailure(..) @@ -274,8 +278,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 +334,11 @@ , ProcessReply , ProcessDefinition(..) , PrioritisedProcessDefinition(..) - , Priority(..) + , Priority() , DispatchPriority , UnhandledMessagePolicy(Drop) + , ExitState + , exitState ) import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe ( call @@ -312,6 +352,7 @@ , prioritiseCall_ , prioritiseInfo_ , setPriority + , evalAfter ) import Control.Distributed.Process.ManagedProcess.Server.Restricted ( RestrictedProcess @@ -335,9 +376,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 +391,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 @@ -370,11 +414,7 @@ ) import Data.Typeable (Typeable) -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch, filter, init, rem) -#else import Prelude hiding (filter, init, rem) -#endif import GHC.Generics @@ -395,70 +435,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 +480,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 +518,9 @@ , shutdownStrategy :: ShutdownMode } +supErrId :: String -> String +supErrId s = "Control.Distributed.Process" ++ s + -------------------------------------------------------------------------------- -- Starting/Running Supervisor -- -------------------------------------------------------------------------------- @@ -598,18 +578,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 +599,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 +618,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 +669,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 +713,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 +724,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 +736,9 @@ , Restricted.handleCall handleListChildren , Restricted.handleCall handleGetStats ] - , infoHandlers = [handleInfo handleMonitorSignal] + , infoHandlers = [ handleInfo handleMonitorSignal + , handleInfo handleDelayedRestart + ] , shutdownHandler = handleShutdown , unhandledMessagePolicy = Drop } :: ProcessDefinition State @@ -883,34 +864,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 +919,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 +936,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 +966,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 +1033,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 +1081,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 +1151,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 +1169,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 +1182,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 +1234,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 +1255,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 +1282,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 +1332,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 +1454,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 +1478,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 +1503,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 +1542,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 +1583,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 +1605,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,136 @@ +{-# 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.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) + deriving (Typeable, Generic, Show, Eq) 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,1366 +1,1453 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} - --- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since --- they rely on ordering constraints which the Cloud Haskell runtime does not --- guarantee. - -module Main where - -import Control.Concurrent.MVar - ( MVar - , newMVar - , putMVar - , takeMVar - ) -import qualified Control.Exception as Ex -import Control.Exception (throwIO) -import Control.Distributed.Process hiding (call, monitor) -import Control.Distributed.Process.Closure -import Control.Distributed.Process.Node -import Control.Distributed.Process.Extras.Internal.Types -import Control.Distributed.Process.Extras.Internal.Primitives -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.ManagedProcess.Client (shutdown) -import Control.Distributed.Process.Serializable() - -import Control.Distributed.Static (staticLabel) -import Control.Monad (void, forM_, forM) -import Control.Rematch - ( equalTo - , is - , isNot - , isNothing - , isJust - ) - -import Data.ByteString.Lazy (empty) -import Data.Maybe (catMaybes) - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - -import Test.HUnit (Assertion, assertFailure) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import TestUtils hiding (waitForExit) -import qualified Network.Transport as NT --- test utilities - -expectedExitReason :: ProcessId -> String -expectedExitReason sup = "killed-by=" ++ (show sup) ++ - ",reason=TerminatedBySupervisor" - -defaultWorker :: ChildStart -> ChildSpec -defaultWorker clj = - ChildSpec - { - childKey = "" - , childType = Worker - , childRestart = Temporary - , childStop = TerminateImmediately - , childStart = clj - , childRegName = Nothing - } - -tempWorker :: ChildStart -> ChildSpec -tempWorker clj = - (defaultWorker clj) - { - childKey = "temp-worker" - , childRestart = Temporary - } - -transientWorker :: ChildStart -> ChildSpec -transientWorker clj = - (defaultWorker clj) - { - childKey = "transient-worker" - , childRestart = Transient - } - -intrinsicWorker :: ChildStart -> ChildSpec -intrinsicWorker clj = - (defaultWorker clj) - { - childKey = "intrinsic-worker" - , childRestart = Intrinsic - } - -permChild :: ChildStart -> ChildSpec -permChild clj = - (defaultWorker clj) - { - childKey = "perm-child" - , childRestart = Permanent - } - -ensureProcessIsAlive :: ProcessId -> Process () -ensureProcessIsAlive pid = do - result <- isProcessAlive pid - expectThat result $ is True - -runInTestContext :: LocalNode - -> MVar () - -> RestartStrategy - -> [ChildSpec] - -> (ProcessId -> Process ()) - -> Assertion -runInTestContext node lock rs cs proc = do - Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do - sup <- Supervisor.start rs ParallelShutdown cs - (proc sup) `finally` (exit sup ExitShutdown) - -verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () -verifyChildWasRestarted key pid sup = do - void $ waitForExit pid - cSpec <- lookupChild sup key - -- TODO: handle (ChildRestarting _) too! - case cSpec of - Just (ref, _) -> do Just pid' <- resolve ref - expectThat pid' $ isNot $ equalTo pid - _ -> do - liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) - -verifyChildWasNotRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () -verifyChildWasNotRestarted key pid sup = do - void $ waitForExit pid - cSpec <- lookupChild sup key - case cSpec of - Just (ChildStopped, _) -> return () - _ -> liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) - -verifyTempChildWasRemoved :: ProcessId -> ProcessId -> Process () -verifyTempChildWasRemoved pid sup = do - void $ waitForExit pid - sleepFor 500 Millis - cSpec <- lookupChild sup "temp-worker" - expectThat cSpec isNothing - -waitForExit :: ProcessId -> Process DiedReason -waitForExit pid = do - monitor pid >>= waitForDown - -waitForDown :: Maybe MonitorRef -> Process DiedReason -waitForDown Nothing = error "invalid mref" -waitForDown (Just ref) = - 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' - -exitIgnore :: Process () -exitIgnore = liftIO $ throwIO ChildInitIgnore - -noOp :: Process () -noOp = return () - -blockIndefinitely :: Process () -blockIndefinitely = runTestProcess noOp - -notifyMe :: ProcessId -> Process () -notifyMe me = getSelfPid >>= send me >> obedient - -sleepy :: Process () -sleepy = (sleepFor 5 Minutes) - `catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy - -obedient :: Process () -obedient = (sleepFor 5 Minutes) - {- supervisor inserts handlers that act like we wrote: - `catchExit` (\_ (r :: ExitReason) -> do - case r of - ExitShutdown -> return () - _ -> die r) - -} - -$(remotable [ 'exitIgnore - , 'noOp - , 'blockIndefinitely - , 'sleepy - , 'obedient - , 'notifyMe]) - --- test cases start here... - -normalStartStop :: ProcessId -> Process () -normalStartStop sup = do - ensureProcessIsAlive sup - void $ monitor sup - shutdown sup - sup `shouldExitWith` DiedNormal - -sequentialShutdown :: TestResult (Maybe ()) -> Process () -sequentialShutdown result = do - (sp, rp) <- newChan - (sg, rg) <- newChan - core' <- toChildStart $ runCore sp - app' <- toChildStart $ runApp sg - let core = (permChild core') { childRegName = Just (LocalName "core") - , childStop = TerminateTimeout (Delay $ within 2 Seconds) - , childKey = "child-1" - } - let app = (permChild app') { childRegName = Just (LocalName "app") - , childStop = TerminateTimeout (Delay $ within 2 Seconds) - , childKey = "child-2" - } - - sup <- Supervisor.start restartRight - (SequentialShutdown RightToLeft) - [core, app] - - () <- receiveChan rg - exit sup ExitShutdown - res <- receiveChanTimeout (asTimeout $ seconds 2) rp - --- whereis "core" >>= liftIO . putStrLn . ("core :" ++) . show --- whereis "app" >>= liftIO . putStrLn . ("app :" ++) . show - - sleepFor 1 Seconds - stash result res - - where - runCore :: SendPort () -> Process () - runCore sp = (expect >>= say) `catchExit` (\_ ExitShutdown -> sendChan sp ()) - - runApp :: SendPort () -> Process () - runApp sg = do - Just pid <- whereis "core" - link pid -- if the real "core" exits first, we go too - sendChan sg () - expect >>= say - -configuredTemporaryChildExitsWithIgnore :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -configuredTemporaryChildExitsWithIgnore cs withSupervisor = - let spec = tempWorker cs in do - withSupervisor restartOne [spec] verifyExit - 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 - Just (ref, _) -> do - Just pid <- resolve ref - verifyTempChildWasRemoved pid sup - -configuredNonTemporaryChildExitsWithIgnore :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -configuredNonTemporaryChildExitsWithIgnore cs withSupervisor = - let spec = transientWorker cs in do - withSupervisor restartOne [spec] $ verifyExit spec - where - verifyExit :: ChildSpec -> ProcessId -> Process () - verifyExit spec sup = do - sleep $ milliSeconds 100 -- make sure our super has seen the EXIT signal - child <- lookupChild sup (childKey spec) - case child of - Nothing -> liftIO $ assertFailure $ "lost non-temp spec!" - Just (ref, spec') -> do - rRef <- resolve ref - maybe (return DiedNormal) waitForExit rRef - cSpec <- lookupChild sup (childKey spec') - case cSpec of - Just (ChildStartIgnored, _) -> return () - _ -> do - liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) - -startTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () -startTemporaryChildExitsWithIgnore cs sup = - -- if a temporary child exits with "ignore" then we must - -- have deleted its specification from the supervisor - let spec = tempWorker cs in do - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - verifyTempChildWasRemoved pid sup - -startNonTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () -startNonTemporaryChildExitsWithIgnore cs sup = - let spec = transientWorker cs in do - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - void $ waitForExit pid - sleep $ milliSeconds 250 - cSpec <- lookupChild sup (childKey spec) - case cSpec of - Just (ChildStartIgnored, _) -> return () - _ -> do - liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) - -addChildWithoutRestart :: ChildStart -> ProcessId -> Process () -addChildWithoutRestart cs sup = - let spec = transientWorker cs in do - response <- addChild sup spec - response `shouldBe` equalTo (ChildAdded ChildStopped) - -addChildThenStart :: ChildStart -> ProcessId -> Process () -addChildThenStart cs sup = - let spec = transientWorker cs in do - (ChildAdded _) <- addChild sup spec - response <- startChild sup (childKey spec) - case response of - ChildStartOk (ChildRunning pid) -> do - alive <- isProcessAlive pid - alive `shouldBe` equalTo True - _ -> do - liftIO $ putStrLn (show response) - die "Ooops" - -startUnknownChild :: ChildStart -> ProcessId -> Process () -startUnknownChild cs sup = do - response <- startChild sup (childKey (transientWorker cs)) - response `shouldBe` equalTo ChildStartUnknownId - -setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec) -setupChild cs sup = do - let spec = transientWorker cs - response <- addChild sup spec - response `shouldBe` equalTo (ChildAdded ChildStopped) - Just child <- lookupChild sup "transient-worker" - return child - -addDuplicateChild :: ChildStart -> ProcessId -> Process () -addDuplicateChild cs sup = do - (ref, spec) <- setupChild cs sup - dup <- addChild sup spec - dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) - -startDuplicateChild :: ChildStart -> ProcessId -> Process () -startDuplicateChild cs sup = do - (ref, spec) <- setupChild cs sup - dup <- startNewChild sup spec - dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) - -startBadClosure :: ChildStart -> ProcessId -> Process () -startBadClosure cs sup = do - let spec = tempWorker cs - child <- startNewChild sup spec - child `shouldBe` equalTo - (ChildFailedToStart $ StartFailureBadClosure - "user error (Could not resolve closure: Invalid static label 'non-existing')") - --- configuredBadClosure withSupervisor = do --- let spec = permChild (closure (staticLabel "non-existing") empty) --- -- we make sure we don't hit the supervisor's limits --- let strategy = RestartOne $ limit (maxRestarts 500000000) (milliSeconds 1) --- withSupervisor strategy [spec] $ \sup -> do --- -- ref <- monitor sup --- children <- (listChildren sup) --- let specs = map fst children --- expectThat specs $ equalTo [] - -deleteExistingChild :: ChildStart -> ProcessId -> Process () -deleteExistingChild cs sup = do - let spec = transientWorker cs - (ChildAdded ref) <- startNewChild sup spec - result <- deleteChild sup "transient-worker" - result `shouldBe` equalTo (ChildNotStopped ref) - -deleteStoppedTempChild :: ChildStart -> ProcessId -> Process () -deleteStoppedTempChild cs sup = do - let spec = tempWorker cs - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - testProcessStop pid - -- child needs to be stopped - waitForExit pid - result <- deleteChild sup (childKey spec) - result `shouldBe` equalTo ChildNotFound - -deleteStoppedChild :: ChildStart -> ProcessId -> Process () -deleteStoppedChild cs sup = do - let spec = transientWorker cs - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - testProcessStop pid - -- child needs to be stopped - waitForExit pid - result <- deleteChild sup (childKey spec) - result `shouldBe` equalTo ChildDeleted - -permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process () -permanentChildrenAlwaysRestart cs sup = do - let spec = permChild cs - (ChildAdded ref) <- startNewChild sup spec - Just pid <- resolve ref - testProcessStop pid -- a normal stop should *still* trigger a restart - verifyChildWasRestarted (childKey spec) pid sup - -temporaryChildrenNeverRestart :: ChildStart -> ProcessId -> Process () -temporaryChildrenNeverRestart cs sup = do - let spec = tempWorker cs - (ChildAdded ref) <- startNewChild sup spec - Just pid <- resolve ref - kill pid "bye bye" - verifyTempChildWasRemoved pid sup - -transientChildrenNormalExit :: ChildStart -> ProcessId -> Process () -transientChildrenNormalExit cs sup = do - let spec = transientWorker cs - (ChildAdded ref) <- startNewChild sup spec - Just pid <- resolve ref - testProcessStop pid - verifyChildWasNotRestarted (childKey spec) pid sup - -transientChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () -transientChildrenAbnormalExit cs sup = do - let spec = transientWorker cs - (ChildAdded ref) <- startNewChild sup spec - Just pid <- resolve ref - kill pid "bye bye" - verifyChildWasRestarted (childKey spec) pid sup - -transientChildrenExitShutdown :: ChildStart -> ProcessId -> Process () -transientChildrenExitShutdown cs sup = do - let spec = transientWorker cs - (ChildAdded ref) <- startNewChild sup spec - Just pid <- resolve ref - exit pid ExitShutdown - verifyChildWasNotRestarted (childKey spec) pid sup - -intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () -intrinsicChildrenAbnormalExit cs sup = do - let spec = intrinsicWorker cs - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - kill pid "bye bye" - verifyChildWasRestarted (childKey spec) pid sup - -intrinsicChildrenNormalExit :: ChildStart -> ProcessId -> Process () -intrinsicChildrenNormalExit cs sup = do - let spec = intrinsicWorker cs - ChildAdded ref <- startNewChild sup spec - Just pid <- resolve ref - testProcessStop pid - reason <- waitForExit sup - expectThat reason $ equalTo DiedNormal - -explicitRestartRunningChild :: ChildStart -> ProcessId -> Process () -explicitRestartRunningChild cs sup = do - let spec = tempWorker cs - ChildAdded ref <- startNewChild sup spec - result <- restartChild sup (childKey spec) - expectThat result $ equalTo $ ChildRestartFailed (StartFailureAlreadyRunning ref) - -explicitRestartUnknownChild :: ProcessId -> Process () -explicitRestartUnknownChild sup = do - result <- restartChild sup "unknown-id" - expectThat result $ equalTo ChildRestartUnknownId - -explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process () -explicitRestartRestartingChild cs sup = do - let spec = permChild cs - ChildAdded _ <- startNewChild sup spec - -- TODO: we've seen a few explosions here (presumably of the supervisor?) - -- expecially when running with +RTS -N1 - it's possible that there's a bug - -- tucked away that we haven't cracked just yet - restarted <- (restartChild sup (childKey spec)) - `catchExit` (\_ (r :: ExitReason) -> (liftIO $ putStrLn (show r)) >> - die r) - -- this is highly timing dependent, so we have to allow for both - -- possible outcomes - on a dual core machine, the first clause - -- will match approx. 1 / 200 times when running with +RTS -N - case restarted of - ChildRestartFailed (StartFailureAlreadyRunning (ChildRestarting _)) -> return () - ChildRestartFailed (StartFailureAlreadyRunning (ChildRunning _)) -> return () - other -> liftIO $ assertFailure $ "unexpected result: " ++ (show other) - -explicitRestartStoppedChild :: ChildStart -> ProcessId -> Process () -explicitRestartStoppedChild cs sup = do - let spec = transientWorker cs - let key = childKey spec - ChildAdded ref <- startNewChild sup spec - void $ terminateChild 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) - -terminateChildImmediately :: ChildStart -> ProcessId -> Process () -terminateChildImmediately cs sup = do - let spec = tempWorker cs - ChildAdded ref <- startNewChild sup spec --- Just pid <- resolve ref - mRef <- monitor ref - void $ terminateChild sup (childKey spec) - reason <- waitForDown mRef - expectThat reason $ equalTo $ DiedException (expectedExitReason sup) - -terminatingChildExceedsDelay :: ProcessId -> Process () -terminatingChildExceedsDelay sup = do - let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy))) - { childStop = TerminateTimeout (Delay $ within 1 Seconds) } - ChildAdded ref <- startNewChild sup spec --- Just pid <- resolve ref - mRef <- monitor ref - void $ terminateChild sup (childKey spec) - reason <- waitForDown mRef - expectThat reason $ equalTo $ DiedException (expectedExitReason sup) - -terminatingChildObeysDelay :: ProcessId -> Process () -terminatingChildObeysDelay sup = do - let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient))) - { childStop = TerminateTimeout (Delay $ within 1 Seconds) } - ChildAdded child <- startNewChild sup spec - Just pid <- resolve child - testProcessGo pid - void $ monitor pid - void $ terminateChild sup (childKey spec) - child `shouldExitWith` DiedNormal - -restartAfterThreeAttempts :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -restartAfterThreeAttempts cs withSupervisor = do - let spec = permChild cs - let strategy = RestartOne $ limit (maxRestarts 500) (seconds 2) - withSupervisor strategy [spec] $ \sup -> do - mapM_ (\_ -> do - [(childRef, _)] <- listChildren sup - Just pid <- resolve childRef - ref <- monitor pid - testProcessStop pid - void $ waitForDown ref) [1..3 :: Int] - [(_, _)] <- listChildren sup - return () - -{- -delayedRestartAfterThreeAttempts :: - (RestartStrategy -> [ChildSpec] -> (ProcessId -> 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 - 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 () - _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref) - sleep $ seconds 2 - [(ref', _)] <- listChildren sup - liftIO $ putStrLn $ "it is: " ++ (show ref') - Just pid <- resolve ref' - mRef <- monitor pid - testProcessStop pid - void $ waitForDown mRef --} - -permanentChildExceedsRestartsIntensity :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -permanentChildExceedsRestartsIntensity cs withSupervisor = do - let spec = permChild cs -- child that exits immediately - let strategy = RestartOne $ limit (maxRestarts 50) (seconds 2) - withSupervisor strategy [spec] $ \sup -> do - ref <- monitor sup - -- if the supervisor dies whilst the call is in-flight, - -- *this* process will exit, therefore we handle that exit reason - void $ ((startNewChild sup spec >> return ()) - `catchExit` (\_ (_ :: ExitReason) -> return ())) - reason <- waitForDown ref - expectThat reason $ equalTo $ - DiedException $ "exit-from=" ++ (show sup) ++ - ",reason=ReachedMaxRestartIntensity" - -terminateChildIgnoresSiblings :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -terminateChildIgnoresSiblings 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 - waitForDown mRef - children <- listChildren sup - forM_ (tail $ map fst children) $ \cRef -> do - maybe (error "invalid ref") ensureProcessIsAlive =<< resolve cRef - -restartAllWithLeftToRightSeqRestarts :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -restartAllWithLeftToRightSeqRestarts cs withSupervisor = do - let templ = permChild cs - let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]] - withSupervisor restartAll specs $ \sup -> 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 snd children) $ \cSpec -> do - Just (ref', _) <- lookupChild sup (childKey cSpec) - maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref' - -restartLeftWithLeftToRightSeqRestarts :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do - 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 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 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) [ - match (\(ProcessMonitorNotification _ pid' _) -> do - case (elem pid' possibleBadRestarts) of - True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' - False -> return ()) - ] - expectThat r isNothing - -restartRightWithLeftToRightSeqRestarts :: - ChildStart - -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) - -> Assertion -restartRightWithLeftToRightSeqRestarts cs withSupervisor = do - let templ = permChild cs - let specs = [templ { childKey = (show i) } | i <- [1..50 :: Int]] - withSupervisor restartRight specs $ \sup -> do - let (_notToRestart, toRestart) = splitAt 40 specs - let toStop = childKey $ head toRestart - Just (ref, _) <- lookupChild sup toStop - Just pid <- resolve ref - children <- listChildren sup - let (survivors, children') = splitAt 40 children - kill pid "goodbye" - forM_ (map fst children') $ \cRef -> do - mRef <- monitor cRef - waitForDown mRef - 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) [ - match (\(ProcessMonitorNotification _ pid' _) -> do - case (elem pid' possibleBadRestarts) of - True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' - False -> return ()) - ] - expectThat r isNothing - -restartAllWithLeftToRightRestarts :: ProcessId -> Process () -restartAllWithLeftToRightRestarts sup = do - self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) - let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]] - -- add the specs one by one - forM_ specs $ \s -> void $ startNewChild sup s - -- assert that we saw the startup sequence working... - children <- listChildren sup - drainAllChildren children - let toStop = childKey $ head specs - Just (ref, _) <- lookupChild sup toStop - Just pid <- resolve ref - kill pid "goodbye" - -- 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')) - ] - -- Now assert that all the children were restarted in the same order. - -- THIS is the bit that is technically unsafe, though it's also unlikely - -- to change, since the architecture of the node controller is pivotal to CH - children' <- listChildren sup - drainAllChildren children' - let [c1, c2] = [map fst cs | cs <- [children, children']] - forM_ (zip c1 c2) $ \(p1, p2) -> expectThat p1 $ isNot $ equalTo p2 - where - drainAllChildren children = 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 - forM_ pids ensureProcessIsAlive - -restartAllWithRightToLeftSeqRestarts :: ProcessId -> Process () -restartAllWithRightToLeftSeqRestarts sup = do - self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) - let specs = [templ { childKey = (show i) } | i <- [1..100 :: 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... - 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 - children' <- listChildren sup - let (ref', _) = last children' - Just pid' <- resolve ref' - drainChildren children' pid' - -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]] - -- 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 - -- 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 - -- 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 - self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) - let specs = [templ { childKey = (show i) } | i <- [1..10 :: 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... - 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 ()) - -- 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' - -restartLeftWhenLeftmostChildDies :: ChildStart -> ProcessId -> Process () -restartLeftWhenLeftmostChildDies cs sup = do - let spec = permChild cs - (ChildAdded ref) <- startNewChild sup spec - (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } - Just pid <- resolve ref - Just pid2 <- resolve ref2 - testProcessStop pid -- a normal stop should *still* trigger a restart - verifyChildWasRestarted (childKey spec) pid sup - Just (ref3, _) <- lookupChild sup "child2" - Just pid2' <- resolve ref3 - pid2 `shouldBe` equalTo pid2' - -restartWithoutTempChildren :: ChildStart -> ProcessId -> Process () -restartWithoutTempChildren cs sup = do - (ChildAdded refTrans) <- startNewChild sup $ transientWorker cs - (ChildAdded _) <- startNewChild sup $ tempWorker cs - (ChildAdded refPerm) <- startNewChild sup $ permChild cs - Just pid2 <- resolve refTrans - Just pid3 <- resolve refPerm - - kill pid2 "foobar" - void $ waitForExit pid2 -- this wait reduces the likelihood of a race in the test - Nothing <- lookupChild sup "temp-worker" - verifyChildWasRestarted "transient-worker" pid2 sup - verifyChildWasRestarted "perm-child" pid3 sup - -restartRightWhenRightmostChildDies :: ChildStart -> ProcessId -> Process () -restartRightWhenRightmostChildDies cs sup = do - let spec = permChild cs - (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } - (ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" } - [ch1, ch2] <- listChildren sup - (fst ch1) `shouldBe` equalTo ref2 - (fst ch2) `shouldBe` equalTo ref - Just pid <- resolve ref - Just pid2 <- resolve ref2 - -- ref (and therefore pid) is 'rightmost' now - testProcessStop pid -- a normal stop should *still* trigger a restart - verifyChildWasRestarted "child1" pid sup - Just (ref3, _) <- lookupChild sup "child2" - Just pid2' <- resolve ref3 - pid2 `shouldBe` equalTo pid2' - -restartLeftWithLeftToRightRestarts :: ProcessId -> Process () -restartLeftWithLeftToRightRestarts sup = do - self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) - let specs = [templ { childKey = (show i) } | i <- [1..20 :: 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 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 - 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]] - 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]] - 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 - 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 - 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 [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]] - 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 - 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 - 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]] - 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]] - 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 - 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 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 - -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 - - procLinkExpect :: SupervisorPid -> Process ProcessId - procLinkExpect p = spawnLocal $ link p >> procExpect - - waitForChildShutdown [] = return () - waitForChildShutdown pids = do - p <- receiveWait [ - match (\(ProcessMonitorNotification _ p _) -> return p) - ] - waitForChildShutdown $ filter (/= p) pids - --- remote table definition and main - -myRemoteTable :: RemoteTable -myRemoteTable = Main.__remoteTable initRemoteTable - -withClosure :: (ChildStart -> ProcessId -> Process ()) - -> (Closure (Process ())) - -> ProcessId -> Process () -withClosure fn clj supervisor = do - cs <- toChildStart clj - fn cs supervisor - -withChan :: (ChildStart -> ProcessId -> Process ()) - -> Process () - -> ProcessId - -> Process () -withChan fn proc supervisor = do - cs <- toChildStart proc - fn cs supervisor - -tests :: NT.Transport -> IO [Test] -tests transport = do - putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) " - , "Can Fail Intermittently"] - localNode <- newLocalNode transport myRemoteTable - singleTestLock <- newMVar () - let withSupervisor = runInTestContext localNode singleTestLock - return - [ testGroup "Supervisor Processes" - [ - testGroup "Starting And Adding Children" - [ - 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)" - (withSupervisor restartOne [] - (withChan addChildWithoutRestart blockIndefinitely)) - , testCase "Start Previously Added Child" - (withSupervisor restartOne [] - (withChan addChildThenStart blockIndefinitely)) - , testCase "Start Unknown Child" - (withSupervisor restartOne [] - (withChan startUnknownChild blockIndefinitely)) - , testCase "Add Duplicate Child (Chan)" - (withSupervisor restartOne [] - (withChan addDuplicateChild blockIndefinitely)) - , testCase "Start Duplicate Child (Chan)" - (withSupervisor restartOne [] - (withChan startDuplicateChild blockIndefinitely)) - , testCase "Started Temporary Child Exits With Ignore (Chan)" - (withSupervisor restartOne [] - (withChan startTemporaryChildExitsWithIgnore exitIgnore)) - , testCase "Started Non-Temporary Child Exits With Ignore (Chan)" - (withSupervisor restartOne [] $ - (withChan startNonTemporaryChildExitsWithIgnore exitIgnore)) - ] - ] - , testGroup "Stopping And Deleting Children" - [ - testCase "Delete Existing Child Fails" - (withSupervisor restartOne [] - (withClosure deleteExistingChild - $(mkStaticClosure 'blockIndefinitely))) - , testCase "Delete Stopped Temporary Child (Doesn't Exist)" - (withSupervisor restartOne [] - (withClosure deleteStoppedTempChild - $(mkStaticClosure 'blockIndefinitely))) - , testCase "Delete Stopped Child Succeeds" - (withSupervisor restartOne [] - (withClosure deleteStoppedChild - $(mkStaticClosure 'blockIndefinitely))) - , testCase "Restart Minus Dropped (Temp) Child" - (withSupervisor restartAll [] - (withClosure restartWithoutTempChildren - $(mkStaticClosure 'blockIndefinitely))) - , testCase "Sequential Shutdown Ordering" - (delayedAssertion - "expected the shutdown order to hold" - localNode (Just ()) sequentialShutdown) - ] - , testGroup "Stopping and Restarting Children" - [ - testCase "Permanent Children Always Restart (Closure)" - (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 - $(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)" - (withSupervisor restartOne [] - (withClosure terminateChildImmediately - $(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) - ] - -- TODO: test for init failures (expecting $ ChildInitFailed r) - , testGroup "Branch Restarts" - [ - testGroup "Restart All" - [ - testCase "Terminate Child Ignores Siblings" - (terminateChildIgnoresSiblings - (RunClosure $(mkStaticClosure 'blockIndefinitely)) - withSupervisor) - , testCase "Restart All, Left To Right (Sequential) Restarts" - (restartAllWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) - withSupervisor) - , testCase "Restart All, Right To Left (Sequential) Restarts" - (withSupervisor - (RestartAll defaultLimits (RestartEach RightToLeft)) [] - restartAllWithRightToLeftSeqRestarts) - , testCase "Restart All, Left To Right Stop, Left To Right Start" - (withSupervisor - (RestartAll defaultLimits (RestartInOrder LeftToRight)) [] - restartAllWithLeftToRightRestarts) - , testCase "Restart All, Right To Left Stop, Right To Left Start" - (withSupervisor - (RestartAll defaultLimits (RestartInOrder RightToLeft)) [] - expectRightToLeftRestarts) - , testCase "Restart All, Left To Right Stop, Reverse Start" - (withSupervisor - (RestartAll defaultLimits (RestartRevOrder LeftToRight)) [] - expectRightToLeftRestarts) - , testCase "Restart All, Right To Left Stop, Reverse Start" - (withSupervisor - (RestartAll defaultLimits (RestartRevOrder RightToLeft)) [] - expectLeftToRightRestarts) - ], - testGroup "Restart Left" - [ - testCase "Restart Left, Left To Right (Sequential) Restarts" - (restartLeftWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) - 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 - (RestartLeft defaultLimits (RestartInOrder LeftToRight)) [] - restartLeftWithLeftToRightRestarts) - , testCase "Restart Left, Right To Left Stop, Right To Left Start" - (withSupervisor - (RestartLeft defaultLimits (RestartInOrder RightToLeft)) [] - restartLeftWithRightToLeftRestarts) - , testCase "Restart Left, Left To Right Stop, Reverse Start" - (withSupervisor - (RestartLeft defaultLimits (RestartRevOrder LeftToRight)) [] - restartLeftWithRightToLeftRestarts) - , testCase "Restart Left, Right To Left Stop, Reverse Start" - (withSupervisor - (RestartLeft defaultLimits (RestartRevOrder RightToLeft)) [] - restartLeftWithLeftToRightRestarts) - ], - testGroup "Restart Right" - [ - testCase "Restart Right, Left To Right (Sequential) Restarts" - (restartRightWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) - withSupervisor) - , testCase "Restart Right, Rightmost Child Dies" - (withSupervisor restartRight [] $ - restartRightWhenRightmostChildDies - (RunClosure $(mkStaticClosure 'blockIndefinitely))) - , testCase "Restart Right, Left To Right Stop, Left To Right Start" - (withSupervisor - (RestartRight defaultLimits (RestartInOrder LeftToRight)) [] - restartRightWithLeftToRightRestarts) - , testCase "Restart Right, Right To Left Stop, Right To Left Start" - (withSupervisor - (RestartRight defaultLimits (RestartInOrder RightToLeft)) [] - restartRightWithRightToLeftRestarts) - , testCase "Restart Right, Left To Right Stop, Reverse Start" - (withSupervisor - (RestartRight defaultLimits (RestartRevOrder LeftToRight)) [] - restartRightWithRightToLeftRestarts) - , testCase "Restart Right, Right To Left Stop, Reverse Start" - (withSupervisor - (RestartRight defaultLimits (RestartRevOrder RightToLeft)) [] - restartRightWithLeftToRightRestarts) - ] - ] - , testGroup "Restart Intensity" - [ - testCase "Three Attempts Before Successful Restart" - (restartAfterThreeAttempts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor) - , 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) - ] - ] - ] - -main :: IO () -main = testMain $ tests - +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since +-- they rely on ordering constraints which the Cloud Haskell runtime does not +-- guarantee. + +module Main where + +import Control.Concurrent.MVar + ( MVar + , newMVar + , putMVar + , takeMVar + ) +import qualified Control.Exception as Ex +import Control.Exception (throwIO) +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, unless, forM_, forM) +import Control.Monad.Catch (finally) + +import Data.ByteString.Lazy (empty) +import Data.Maybe (catMaybes, isNothing, isJust) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, assertBool, 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=StoppedBySupervisor" + +defaultWorker :: ChildStart -> ChildSpec +defaultWorker clj = + ChildSpec + { + childKey = "" + , childType = Worker + , childRestart = Temporary + , childRestartDelay = Nothing + , childStop = StopImmediately + , childStart = clj + , childRegName = Nothing + } + +tempWorker :: ChildStart -> ChildSpec +tempWorker clj = + (defaultWorker clj) + { + childKey = "temp-worker" + , childRestart = Temporary + } + +transientWorker :: ChildStart -> ChildSpec +transientWorker clj = + (defaultWorker clj) + { + childKey = "transient-worker" + , childRestart = Transient + } + +intrinsicWorker :: ChildStart -> ChildSpec +intrinsicWorker clj = + (defaultWorker clj) + { + childKey = "intrinsic-worker" + , childRestart = Intrinsic + } + +permChild :: ChildStart -> ChildSpec +permChild clj = + (defaultWorker clj) + { + childKey = "perm-child" + , childRestart = Permanent + } + +ensureProcessIsAlive :: ProcessId -> Process () +ensureProcessIsAlive pid = do + result <- isProcessAlive pid + liftIO $ assertBool mempty result + +runInTestContext :: LocalNode + -> MVar () + -> ShutdownMode + -> RestartStrategy + -> [ChildSpec] + -> (ProcessId -> Process ()) + -> Assertion +runInTestContext node lock sm rs cs proc = do + Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do + 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 + cSpec <- lookupChild sup key + -- TODO: handle (ChildRestarting _) too! + case cSpec of + Just (ref, _) -> do Just pid' <- resolve ref + liftIO $ assertBool mempty ( pid' /= pid) + _ -> do + liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) + +verifyChildWasNotRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () +verifyChildWasNotRestarted key pid sup = do + void $ waitForExit pid + cSpec <- lookupChild sup key + case cSpec of + Just (ChildStopped, _) -> return () + _ -> liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) + +verifyTempChildWasRemoved :: ProcessId -> ProcessId -> Process () +verifyTempChildWasRemoved pid sup = do + void $ waitForExit pid + sleepFor 500 Millis + cSpec <- lookupChild sup "temp-worker" + liftIO $ assertBool mempty (isNothing cSpec) + +waitForExit :: ProcessId -> Process DiedReason +waitForExit pid = do + monitor pid >>= waitForDown + +waitForDown :: Maybe MonitorRef -> Process DiedReason +waitForDown Nothing = error "invalid mref" +waitForDown (Just ref) = + receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\(ProcessMonitorNotification _ _ dr) -> return dr) ] + +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 + liftIO $ assertEqual mempty (childSpecKey rs) key + mx' <- receiveChanTimeout t sniffer + case mx' of + Just cs@SupervisedChildStarted{} -> do + liftIO $ assertEqual mempty (childSpecKey cs) 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) + liftIO $ assertEqual mempty childSpecKey (childKey cs) + unless (childSpecKey == toStop) $ do + Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer + debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr) + liftIO $ assertEqual mempty childRef oCr + mx' <- receiveChanTimeout t sniffer + case mx' of + Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef 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) + liftIO $ assertEqual mempty childSpecKey (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{..} -> liftIO $ assertEqual mempty childRef 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{..} -> liftIO $ assertEqual mempty childRef cr + _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) + +exitIgnore :: Process () +exitIgnore = liftIO $ throwIO ChildInitIgnore + +noOp :: Process () +noOp = return () + +blockIndefinitely :: Process () +blockIndefinitely = runTestProcess noOp + +notifyMe :: ProcessId -> Process () +notifyMe me = getSelfPid >>= send me >> obedient + +sleepy :: Process () +sleepy = (sleepFor 5 Minutes) + `catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy + +obedient :: Process () +obedient = (sleepFor 5 Minutes) + {- supervisor inserts handlers that act like we wrote: + `catchExit` (\_ (r :: ExitReason) -> do + case r of + ExitShutdown -> return () + _ -> 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 + , 'runCore + , 'runApp + , 'formatMxSupervisor ]) + +-- test cases start here... + +normalStartStop :: ProcessId -> Process () +normalStartStop sup = do + ensureProcessIsAlive sup + void $ monitor sup + shutdown sup + sup `shouldExitWith` DiedNormal + +sequentialShutdown :: TestResult (Maybe ()) -> Process () +sequentialShutdown result = do + (sp, rp) <- newChan + (sg, rg) <- newChan + + core' <- toChildStart $ $(mkClosure 'runCore) sp + app' <- toChildStart $ $(mkClosure 'runApp) sg + let core = (permChild core') { childRegName = Just (LocalName "core") + , childStop = StopTimeout (Delay $ within 2 Seconds) + , childKey = "child-1" + } + let app = (permChild app') { childRegName = Just (LocalName "app") + , childStop = StopTimeout (Delay $ within 2 Seconds) + , childKey = "child-2" + } + + sup <- Supervisor.start restartRight + (SequentialShutdown RightToLeft) + [core, app] + + () <- receiveChan rg + exit sup ExitShutdown + res <- receiveChanTimeout (asTimeout $ seconds 5) rp + stash result res + +configuredTemporaryChildExitsWithIgnore :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +configuredTemporaryChildExitsWithIgnore cs withSupervisor = + let spec = tempWorker cs in do + withSupervisor restartOne [spec] verifyExit + where + verifyExit :: ProcessId -> Process () + verifyExit sup = do + child <- lookupChild sup "temp-worker" + case child of + Nothing -> return () -- the child exited and was removed ok + Just (ref, _) -> do + Just pid <- resolve ref + verifyTempChildWasRemoved pid sup + +configuredNonTemporaryChildExitsWithIgnore :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +configuredNonTemporaryChildExitsWithIgnore cs withSupervisor = + let spec = transientWorker cs in do + withSupervisor restartOne [spec] $ verifyExit spec + where + verifyExit :: ChildSpec -> ProcessId -> Process () + verifyExit spec sup = do + sleep $ milliSeconds 100 -- make sure our super has seen the EXIT signal + child <- lookupChild sup (childKey spec) + case child of + Nothing -> liftIO $ assertFailure $ "lost non-temp spec!" + Just (ref, spec') -> do + rRef <- resolve ref + maybe (return DiedNormal) waitForExit rRef + cSpec <- lookupChild sup (childKey spec') + case cSpec of + Just (ChildStartIgnored, _) -> return () + _ -> do + liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) + +startTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () +startTemporaryChildExitsWithIgnore cs sup = + -- if a temporary child exits with "ignore" then we must + -- have deleted its specification from the supervisor + let spec = tempWorker cs in do + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + verifyTempChildWasRemoved pid sup + +startNonTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () +startNonTemporaryChildExitsWithIgnore cs sup = + let spec = transientWorker cs in do + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + void $ waitForExit pid + sleep $ milliSeconds 250 + cSpec <- lookupChild sup (childKey spec) + case cSpec of + Just (ChildStartIgnored, _) -> return () + _ -> do + liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) + +addChildWithoutRestart :: ChildStart -> ProcessId -> Process () +addChildWithoutRestart cs sup = + let spec = transientWorker cs in do + response <- addChild sup spec + liftIO $ assertEqual mempty response (ChildAdded ChildStopped) + +addChildThenStart :: ChildStart -> ProcessId -> Process () +addChildThenStart cs sup = + let spec = transientWorker cs in do + (ChildAdded _) <- addChild sup spec + response <- startChild sup (childKey spec) + case response of + ChildStartOk (ChildRunning pid) -> do + alive <- isProcessAlive pid + liftIO $ assertBool mempty alive + _ -> do + liftIO $ putStrLn (show response) + die "Ooops" + +startUnknownChild :: ChildStart -> ProcessId -> Process () +startUnknownChild cs sup = do + response <- startChild sup (childKey (transientWorker cs)) + liftIO $ assertEqual mempty response ChildStartUnknownId + +setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec) +setupChild cs sup = do + let spec = transientWorker cs + response <- addChild sup spec + liftIO $ assertEqual mempty response (ChildAdded ChildStopped) + Just child <- lookupChild sup "transient-worker" + return child + +addDuplicateChild :: ChildStart -> ProcessId -> Process () +addDuplicateChild cs sup = do + (ref, spec) <- setupChild cs sup + dup <- addChild sup spec + liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) + +startDuplicateChild :: ChildStart -> ProcessId -> Process () +startDuplicateChild cs sup = do + (ref, spec) <- setupChild cs sup + dup <- startNewChild sup spec + liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) + +startBadClosure :: ChildStart -> ProcessId -> Process () +startBadClosure cs sup = do + let spec = tempWorker cs + child <- startNewChild sup spec + liftIO $ assertEqual mempty child + (ChildFailedToStart $ StartFailureBadClosure + "user error (Could not resolve closure: Invalid static label 'non-existing')") + +-- configuredBadClosure withSupervisor = do +-- let spec = permChild (closure (staticLabel "non-existing") empty) +-- -- we make sure we don't hit the supervisor's limits +-- let strategy = RestartOne $ limit (maxRestarts 500000000) (milliSeconds 1) +-- withSupervisor strategy [spec] $ \sup -> do +-- -- ref <- monitor sup +-- children <- (listChildren sup) +-- let specs = map fst children +-- expectThat specs $ equalTo [] + +deleteExistingChild :: ChildStart -> ProcessId -> Process () +deleteExistingChild cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + result <- deleteChild sup "transient-worker" + liftIO $ assertEqual mempty result (ChildNotStopped ref) + +deleteStoppedTempChild :: ChildStart -> ProcessId -> Process () +deleteStoppedTempChild cs sup = do + let spec = tempWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + -- child needs to be stopped + waitForExit pid + result <- deleteChild sup (childKey spec) + liftIO $ assertEqual mempty result ChildNotFound + +deleteStoppedChild :: ChildStart -> ProcessId -> Process () +deleteStoppedChild cs sup = do + let spec = transientWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + -- child needs to be stopped + waitForExit pid + result <- deleteChild sup (childKey spec) + liftIO $ assertEqual mempty result ChildDeleted + +permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process () +permanentChildrenAlwaysRestart cs sup = do + let spec = permChild cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted (childKey spec) pid sup + +temporaryChildrenNeverRestart :: ChildStart -> ProcessId -> Process () +temporaryChildrenNeverRestart cs sup = do + let spec = tempWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyTempChildWasRemoved pid sup + +transientChildrenNormalExit :: ChildStart -> ProcessId -> Process () +transientChildrenNormalExit cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + verifyChildWasNotRestarted (childKey spec) pid sup + +transientChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () +transientChildrenAbnormalExit cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyChildWasRestarted (childKey spec) pid sup + +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) + liftIO $ assertBool mempty (isNothing mx) + verifyChildWasNotRestarted (childKey spec) pid sup + +intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () +intrinsicChildrenAbnormalExit cs sup = do + let spec = intrinsicWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyChildWasRestarted (childKey spec) pid sup + +intrinsicChildrenNormalExit :: ChildStart -> ProcessId -> Process () +intrinsicChildrenNormalExit cs sup = do + let spec = intrinsicWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + reason <- waitForExit sup + liftIO $ assertEqual mempty reason DiedNormal + +explicitRestartRunningChild :: ChildStart -> ProcessId -> Process () +explicitRestartRunningChild cs sup = do + let spec = tempWorker cs + ChildAdded ref <- startNewChild sup spec + result <- restartChild sup (childKey spec) + liftIO $ assertEqual mempty result (ChildRestartFailed (StartFailureAlreadyRunning ref)) + +explicitRestartUnknownChild :: ProcessId -> Process () +explicitRestartUnknownChild sup = do + result <- restartChild sup "unknown-id" + liftIO $ assertEqual mempty result ChildRestartUnknownId + +explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process () +explicitRestartRestartingChild cs sup = do + let spec = permChild cs + ChildAdded _ <- startNewChild sup spec + -- TODO: we've seen a few explosions here (presumably of the supervisor?) + -- expecially when running with +RTS -N1 - it's possible that there's a bug + -- tucked away that we haven't cracked just yet + restarted <- (restartChild sup (childKey spec)) + `catchExit` (\_ (r :: ExitReason) -> (liftIO $ putStrLn (show r)) >> + die r) + -- this is highly timing dependent, so we have to allow for both + -- possible outcomes - on a dual core machine, the first clause + -- will match approx. 1 / 200 times when running with +RTS -N + case restarted of + ChildRestartFailed (StartFailureAlreadyRunning (ChildRestarting _)) -> return () + ChildRestartFailed (StartFailureAlreadyRunning (ChildRunning _)) -> return () + other -> liftIO $ assertFailure $ "unexpected result: " ++ (show other) + +explicitRestartStoppedChild :: ChildStart -> ProcessId -> Process () +explicitRestartStoppedChild cs sup = do + let spec = transientWorker cs + let key = childKey spec + ChildAdded ref <- startNewChild sup spec + void $ stopChild sup key + restarted <- restartChild sup key + sleepFor 500 Millis + Just (ref', _) <- lookupChild sup key + liftIO $ assertBool mempty (ref /= ref') + case restarted of + ChildRestartOk (ChildRunning _) -> return () + _ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted) + +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 $ stopChild sup (childKey spec) + reason <- waitForDown mRef + liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) + +stoppingChildExceedsDelay :: ProcessId -> Process () +stoppingChildExceedsDelay sup = do + let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy))) + { childStop = StopTimeout (Delay $ within 500 Millis) } + ChildAdded ref <- startNewChild sup spec +-- Just pid <- resolve ref + mRef <- monitor ref + void $ stopChild sup (childKey spec) + reason <- waitForDown mRef + liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) + +stoppingChildObeysDelay :: ProcessId -> Process () +stoppingChildObeysDelay sup = do + let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient))) + { childStop = StopTimeout (Delay $ within 1 Seconds) } + ChildAdded child <- startNewChild sup spec + Just pid <- resolve child + void $ monitor pid + void $ stopChild sup (childKey spec) + child `shouldExitWith` DiedNormal + +restartAfterThreeAttempts :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +restartAfterThreeAttempts cs withSupervisor = do + let spec = permChild cs + let strategy = RestartOne $ limit (maxRestarts 500) (seconds 2) + withSupervisor strategy [spec] $ \sup -> do + mapM_ (\_ -> do + [(childRef, _)] <- listChildren sup + Just pid <- resolve childRef + ref <- monitor pid + testProcessStop pid + void $ waitForDown ref) [1..3 :: Int] + [(_, _)] <- listChildren sup + return () + +delayedRestartAfterThreeAttempts :: + (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion) + -> Assertion +delayedRestartAfterThreeAttempts withSupervisor = 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 _ -> do + SupervisedChildStarted{..} <- receiveChan sniffer + liftIO $ assertEqual mempty childSpecKey (childKey spec) + _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref) + + mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int] + + [(ref', _)] <- listChildren sup + Just pid <- resolve ref' + mRef <- monitor pid + testProcessStop pid + void $ waitForDown mRef + +permanentChildExceedsRestartsIntensity :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +permanentChildExceedsRestartsIntensity cs withSupervisor = do + let spec = permChild cs -- child that exits immediately + let strategy = RestartOne $ limit (maxRestarts 50) (seconds 2) + withSupervisor strategy [spec] $ \sup -> do + ref <- monitor sup + -- if the supervisor dies whilst the call is in-flight, + -- *this* process will exit, therefore we handle that exit reason + void $ ((startNewChild sup spec >> return ()) + `catchExit` (\_ (_ :: ExitReason) -> return ())) + reason <- waitForDown ref + liftIO $ assertEqual mempty reason $ + DiedException $ "exit-from=" ++ (show sup) ++ + ",reason=ReachedMaxRestartIntensity" + +stopChildIgnoresSiblings :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +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 + stopChild sup toStop + waitForDown mRef + children <- listChildren sup + forM_ (tail $ map fst children) $ \cRef -> do + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve cRef + +restartAllWithLeftToRightSeqRestarts :: + ChildStart + -> (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..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 -> 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] -> (Context -> Process ()) -> Assertion) + -> Assertion +restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do + let (lSz, sptSz) = randomIshSizes + let templ = permChild cs + 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 + kill pid "goodbye" + + 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 5 Seconds) [ + match (\(ProcessMonitorNotification _ pid' _) -> do + case (elem pid' possibleBadRestarts) of + True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' + False -> return ()) + ] + liftIO $ assertBool mempty (isNothing r) + +restartRightWithLeftToRightSeqRestarts :: + ChildStart + -> (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..lSz :: Int]] + withSupervisor restartRight specs $ \sup -> do + 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 sptSz children + kill pid "goodbye" + forM_ (map fst children') $ \cRef -> do + mRef <- monitor cRef + waitForDown mRef + 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) [ + match (\(ProcessMonitorNotification _ pid' _) -> do + case (elem pid' possibleBadRestarts) of + True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' + False -> return ()) + ] + liftIO $ assertBool mempty (isNothing r) + +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..lSz :: Int]] + -- add the specs one by one + forM_ specs $ \s -> void $ startNewChild sup s + -- assert that we saw the startup sequence working... + children <- listChildren sup + drainAllChildren children + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + kill pid "goodbye" + -- 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')) + ] + -- Now assert that all the children were restarted in the same order. + -- THIS is the bit that is technically unsafe, though it's also unlikely + -- to change, since the architecture of the node controller is pivotal to CH + children' <- listChildren sup + drainAllChildren children' + let [c1, c2] = [map fst cs | cs <- [children, children']] + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertBool mempty (p1 /= p2) + where + drainAllChildren children = 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 + forM_ pids ensureProcessIsAlive + +restartAllWithRightToLeftSeqRestarts :: Context -> Process () +restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do + self <- getSelfPid + 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 + kill pid "fooboo" + + -- wait for all the exit signals, so we know the children are restarting + 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 xs = zip [fst o | o <- children] children' + verifySeqStartOrder ctx (reverse xs) toStop + + 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 -> 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 + + -- 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) ] + liftIO $ assertBool mempty (isJust initRes) + + forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do + (ProcessMonitorNotification ref' _ _) <- expect + if ref' == mRef then (return ()) else (die "unexpected monitor signal") + +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..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 + kill pid "fooboobarbazbub" + + -- wait for all the exit signals, so we know the children are restarting + 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 + (ChildAdded ref) <- startNewChild sup spec + (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } + Just pid <- resolve ref + Just pid2 <- resolve ref2 + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted (childKey spec) pid sup + Just (ref3, _) <- lookupChild sup "child2" + Just pid2' <- resolve ref3 + liftIO $ assertEqual mempty pid2 pid2' + +restartWithoutTempChildren :: ChildStart -> ProcessId -> Process () +restartWithoutTempChildren cs sup = do + (ChildAdded refTrans) <- startNewChild sup $ transientWorker cs + (ChildAdded _) <- startNewChild sup $ tempWorker cs + (ChildAdded refPerm) <- startNewChild sup $ permChild cs + Just pid2 <- resolve refTrans + Just pid3 <- resolve refPerm + + kill pid2 "foobar" + void $ waitForExit pid2 -- this wait reduces the likelihood of a race in the test + Nothing <- lookupChild sup "temp-worker" + verifyChildWasRestarted "transient-worker" pid2 sup + verifyChildWasRestarted "perm-child" pid3 sup + +restartRightWhenRightmostChildDies :: ChildStart -> ProcessId -> Process () +restartRightWhenRightmostChildDies cs sup = do + let spec = permChild cs + (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } + (ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" } + [ch1, ch2] <- listChildren sup + liftIO $ do + assertEqual mempty (fst ch1) ref2 + assertEqual mempty (fst ch2) ref + Just pid <- resolve ref + Just pid2 <- resolve ref2 + -- ref (and therefore pid) is 'rightmost' now + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted "child1" pid sup + Just (ref3, _) <- lookupChild sup "child2" + Just pid2' <- resolve ref3 + liftIO $ assertEqual mempty pid2 pid2' + +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..listSize :: Int]] + forM_ specs $ \s -> void $ startNewChild sup s + + -- assert that we saw the startup sequence working... + children <- listChildren sup + 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 $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + 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) -> liftIO $ assertEqual mempty p1 p2 + +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 + + children <- listChildren sup + + -- 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 $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + 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) -> liftIO $ assertEqual mempty p1 p2 + +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 + + children <- listChildren sup + + -- 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 $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + 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) -> liftIO $ assertEqual mempty p1 p2 + +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 + + children <- listChildren sup + + -- 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 "test process waves goodbye...." + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown + + 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' + + verifyStopStartOrder ctx xs (reverse restarted) toStop + + let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]] + forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 + +-- remote table definition and main + +myRemoteTable :: RemoteTable +myRemoteTable = Main.__remoteTable initRemoteTable + +withClosure :: (ChildStart -> ProcessId -> Process ()) + -> (Closure (Process ())) + -> ProcessId -> Process () +withClosure fn clj supervisor = do + cs <- toChildStart clj + 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 TestTree +tests transport = do + putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) " + , "Can Fail Intermittently" ] + localNode <- newLocalNode transport myRemoteTable + singleTestLock <- newMVar () + 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" + [ + testGroup "Starting And Adding Children" + [ + testCase "Normal (Managed Process) Supervisor Start Stop" + (withSupervisor restartOne [] normalStartStop) + , 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 "Stopping And Deleting Children" + [ + testCase "Delete Existing Child Fails" + (withSupervisor restartOne [] + (withClosure deleteExistingChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Delete Stopped Temporary Child (Doesn't Exist)" + (withSupervisor restartOne [] + (withClosure deleteStoppedTempChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Delete Stopped Child Succeeds" + (withSupervisor restartOne [] + (withClosure deleteStoppedChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Restart Minus Dropped (Temp) Child" + (withSupervisor restartAll [] + (withClosure restartWithoutTempChildren + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Sequential Shutdown Ordering" + (delayedAssertion + "expected the shutdown order to hold" + localNode (Just ()) sequentialShutdown) + ] + , testGroup "Stopping and Restarting Children" + [ + testCase "Permanent Children Always Restart (Closure)" + (withSupervisor restartOne [] + (withClosure permanentChildrenAlwaysRestart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Temporary Children Never Restart (Closure)" + (withSupervisor restartOne [] + (withClosure temporaryChildrenNeverRestart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Transient Children Do Not Restart When Exiting Normally (Closure)" + (withSupervisor restartOne [] + (withClosure transientChildrenNormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Transient Children Do Restart When Exiting Abnormally (Closure)" + (withSupervisor restartOne [] + (withClosure transientChildrenAbnormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "ExitShutdown Is Considered Normal" + (withSupervisor' restartOne [] + (withClosure' transientChildrenExitShutdown + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)" + (withSupervisor restartOne [] + (withClosure intrinsicChildrenAbnormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase (concat [ "Intrinsic Children Cause Supervisor Exits " + , "When Exiting Normally (Closure)"]) + (withSupervisor restartOne [] + (withClosure intrinsicChildrenNormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Explicit Restart Of Running Child Fails (Closure)" + (withSupervisor restartOne [] + (withClosure explicitRestartRunningChild + $(mkStaticClosure '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 Stopped Child (Closure)" + (withSupervisor restartOne [] + (withClosure explicitRestartStoppedChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Immediate Child Stop (Brutal Kill) (Closure)" + (withSupervisor restartOne [] + (withClosure stopChildImmediately + $(mkStaticClosure 'blockIndefinitely))) + , 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 "Stop Child Ignores Siblings" + (stopChildIgnoresSiblings + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor) + , testCase "Restart All, Left To Right (Sequential) Restarts" + (restartAllWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor') + , testCase "Restart All, Right To Left (Sequential) Restarts" + (withSupervisor' + (RestartAll defaultLimits (RestartEach RightToLeft)) [] + restartAllWithRightToLeftSeqRestarts) + , testCase "Restart All, Left To Right Stop, Left To Right Start" + (withSup + (SequentialShutdown LeftToRight) + (RestartAll defaultLimits (RestartInOrder LeftToRight)) [] + restartAllWithLeftToRightRestarts) + , testCase "Restart All, Right To Left Stop, Right To Left Start" + (withSup' + (SequentialShutdown RightToLeft) + (RestartAll defaultLimits (RestartInOrder RightToLeft) + ) [] + (expectRightToLeftRestarts False)) + , testCase "Restart All, Left To Right Stop, Reverse Start" + (withSup' + (SequentialShutdown LeftToRight) + (RestartAll defaultLimits (RestartRevOrder LeftToRight) + ) [] + (expectRightToLeftRestarts True)) + , testCase "Restart All, Right To Left Stop, Reverse Start" + (withSup' + (SequentialShutdown RightToLeft) + (RestartAll defaultLimits (RestartRevOrder RightToLeft) + ) [] + expectLeftToRightRestarts) + ], + testGroup "Restart Left" + [ + testCase "Restart Left, Left To Right (Sequential) Restarts" + (restartLeftWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + 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' + (RestartLeft defaultLimits (RestartInOrder LeftToRight)) [] + (restartLeftWithLeftToRightRestarts False)) + , testCase "Restart Left, Right To Left Stop, Right To Left Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartInOrder RightToLeft)) [] + (restartLeftWithRightToLeftRestarts True)) + , testCase "Restart Left, Left To Right Stop, Reverse Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartRevOrder LeftToRight)) [] + (restartLeftWithRightToLeftRestarts False)) + , testCase "Restart Left, Right To Left Stop, Reverse Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartRevOrder RightToLeft)) [] + (restartLeftWithLeftToRightRestarts True)) + ], + testGroup "Restart Right" + [ + testCase "Restart Right, Left To Right (Sequential) Restarts" + (restartRightWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor) + , testCase "Restart Right, Rightmost Child Dies" + (withSupervisor restartRight [] $ + restartRightWhenRightmostChildDies + (RunClosure $(mkStaticClosure 'blockIndefinitely))) + , testCase "Restart Right, Left To Right Stop, Left To Right Start" + (withSupervisor' + (RestartRight defaultLimits (RestartInOrder LeftToRight)) [] + (restartRightWithLeftToRightRestarts False)) + , testCase "Restart Right, Right To Left Stop, Right To Left Start" + (withSupervisor' + (RestartRight defaultLimits (RestartInOrder RightToLeft)) [] + (restartRightWithRightToLeftRestarts True)) + , testCase "Restart Right, Left To Right Stop, Reverse Start" + (withSupervisor' + (RestartRight defaultLimits (RestartRevOrder LeftToRight)) [] + (restartRightWithRightToLeftRestarts False)) + , testCase "Restart Right, Right To Left Stop, Reverse Start" + (withSupervisor' + (RestartRight defaultLimits (RestartRevOrder RightToLeft)) [] + (restartRightWithLeftToRightRestarts True)) + ] + ] + , testGroup "Restart Intensity" + [ + testCase "Three Attempts Before Successful Restart" + (restartAfterThreeAttempts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor) + , testCase "Permanent Child Exceeds Restart Limits" + (permanentChildExceedsRestartsIntensity + (RunClosure $(mkStaticClosure 'noOp)) withSupervisor) + , testCase "Permanent Child Delayed Restart" + (delayedRestartAfterThreeAttempts withSupervisor') + ] + ] + +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 #-} @@ -7,12 +8,7 @@ -- ping ! , Ping(Ping) , ping - , shouldBe - , shouldMatch - , shouldContain - , shouldNotContain , shouldExitWith - , expectThat -- test process utilities , TestProcessControl , startTestProcess @@ -35,9 +31,6 @@ , stash ) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif import Control.Concurrent ( ThreadId , myThreadId @@ -56,7 +49,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,12 +58,10 @@ 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 -import Test.HUnit (Assertion, assertFailure) -import Test.HUnit.Base (assertBool) -import Test.Framework (Test, defaultMain) +import Test.Tasty (TestTree, defaultMain) +import Test.Tasty.HUnit (Assertion, assertEqual, assertBool) import Control.DeepSeq import Network.Transport.TCP @@ -80,32 +71,11 @@ import Data.Typeable import GHC.Generics ---expect :: a -> Matcher a -> Process () ---expect a m = liftIO $ Rematch.expect a m - -expectThat :: a -> Matcher a -> Process () -expectThat a matcher = case res of - MatchSuccess -> return () - (MatchFailure msg) -> liftIO $ assertFailure msg - where res = runMatch matcher a - -shouldBe :: a -> Matcher a -> Process () -shouldBe = expectThat - -shouldContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldContain xs x = expectThat xs $ hasItem (equalTo x) - -shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) - -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') ] - d `shouldBe` equalTo r + liftIO $ assertEqual mempty d r waitForExit :: MVar ExitReason -> Process (Maybe ExitReason) @@ -121,8 +91,8 @@ mkNode :: String -> IO LocalNode mkNode port = do - Right (transport1, _) <- createTransportExposeInternals - "127.0.0.1" port defaultTCPParameters + Right (transport1, _) <- + createTransportExposeInternals (defaultTCPAddr "127.0.0.1" port) defaultTCPParameters newLocalNode transport1 initRemoteTable -- | Run the supplied @testProc@ using an @MVar@ to collect and assert @@ -152,7 +122,8 @@ q <- liftIO $ newTQueueIO _ <- forkIO $ logger q return $ Logger tid q - where logger q' = forever $ do + where + logger q' = forever $ do msg <- atomically $ readTQueue q' putStrLn msg @@ -165,10 +136,9 @@ stopLogger = (flip Exception.throwTo) Exception.ThreadKilled . _tid -- | Given a @builder@ function, make and run a test suite on a single transport -testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain :: (NT.Transport -> IO TestTree) -> IO () testMain builder = do - Right (transport, _) <- createTransportExposeInternals - "127.0.0.1" "0" defaultTCPParameters + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters testData <- builder transport defaultMain testData