distributed-process-supervisor 0.1.3.2 → 0.2.4
raw patch · 10 files changed
Files
- ChangeLog +14/−0
- LICENCE +0/−30
- LICENSE +30/−0
- Setup.lhs +0/−3
- distributed-process-supervisor.cabal +81/−61
- src/Control/Distributed/Process/Supervisor.hs +328/−302
- src/Control/Distributed/Process/Supervisor/Management.hs +136/−0
- src/Control/Distributed/Process/Supervisor/Types.hs +128/−51
- tests/TestSupervisor.hs +1451/−1364
- tests/TestUtils.hs +13/−43
ChangeLog view
@@ -1,3 +1,17 @@+2025-02-04 Laurent P. René de Cotret <laurent.decotret@outlook.com> 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 <laurent.decotret@outlook.com> 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 <facundo.dominguez@tweag.io> 0.2.1++* Update dependency bounds.+ 2016-02-16 Facundo Domínguez <facundo.dominguez@tweag.io> 0.1.3.2 * Update dependency bounds.
− LICENCE
@@ -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.
+ LICENSE view
@@ -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.
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
distributed-process-supervisor.cabal view
@@ -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 <facundo.dominguez@tweag.io>+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
src/Control/Distributed/Process/Supervisor.hs view
@@ -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)
+ src/Control/Distributed/Process/Supervisor/Management.hs view
@@ -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 <watson.timothy@gmail.com>+-- Stability : experimental+-- Portability : non-portable (requires concurrency)+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Supervisor.Management+ ( supervisionAgentId+ , supervisionMonitor+ , monitorSupervisor+ , unmonitorSupervisor+ -- * Mx Event Type+ , MxSupervisor(..)+ )+where+import Control.DeepSeq (NFData)+import Control.Distributed.Process+ ( ProcessId+ , Process()+ , ReceivePort()+ , newChan+ , sendChan+ , getSelfPid+ , unwrapMessage+ )+import Control.Distributed.Process.Internal.Types (SendPort(..))+import Control.Distributed.Process.Management+ ( MxAgentId(..)+ , MxAgent()+ , MxEvent(MxProcessDied, MxUser)+ , mxAgent+ , mxSink+ , mxReady+ , liftMX+ , mxGetLocal+ , mxSetLocal+ , mxNotify+ )+import Control.Distributed.Process.Supervisor.Types+ ( MxSupervisor(..)+ , SupervisorPid+ )+import Data.Binary+import Data.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 ()
src/Control/Distributed/Process/Supervisor/Types.hs view
@@ -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
tests/TestSupervisor.hs view
@@ -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
tests/TestUtils.hs view
@@ -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