diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the author nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/distributed-process-supervisor.cabal b/distributed-process-supervisor.cabal new file mode 100644 --- /dev/null +++ b/distributed-process-supervisor.cabal @@ -0,0 +1,97 @@ +name: distributed-process-supervisor +version: 0.1.1 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +license-file: LICENCE +stability: experimental +Copyright: Tim Watson 2012 - 2013 +Author: Tim Watson +Maintainer: watson.timothy@gmail.com +Stability: experimental +Homepage: http://github.com/haskell-distributed/distributed-process-supervisor +Bug-Reports: http://github.com/haskell-distributed/distributed-process-supervisor/issues +synopsis: Supervisors for The Cloud Haskell Application Platform +description: A part of the Cloud Haskell framework + + This package implements a process which supervises a set of other processes, referred to as its children. + These child processes can be either workers (i.e., processes that do something useful in your application) + or other supervisors. In this way, supervisors may be used to build a hierarchical process structure + called a supervision tree, which provides a convenient structure for building fault tolerant software. + + For detailed information see "Control.Distributed.Process.Supervisor" +category: Control +tested-with: GHC == 7.4.2 GHC == 7.6.2 +data-dir: "" + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-supervisor + +library + build-depends: + base >= 4.4 && < 5, + data-accessor >= 0.2.2.3, + distributed-process >= 0.5.2 && < 0.6, + distributed-process-extras >= 0.1.1 && < 0.2, + distributed-process-client-server >= 0.1.1 && < 0.2, + binary >= 0.6.3.0 && < 0.8, + deepseq >= 1.3.0.1 && < 1.4, + 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.5, + 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 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: + Control.Distributed.Process.Supervisor + other-modules: + Control.Distributed.Process.Supervisor.Types + +test-suite SupervisorTests + type: exitcode-stdio-1.0 + build-depends: + base >= 4.4 && < 5, + ansi-terminal >= 0.5 && < 0.7, + containers, + unordered-containers, + hashable, + distributed-process >= 0.5.2 && < 0.6, + distributed-process-supervisor, + distributed-process-extras, + 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.5, + binary >= 0.6.3.0 && < 0.8, + deepseq >= 1.3.0.1 && < 1.4, + network >= 2.3 && < 2.7, + HUnit >= 1.2 && < 2, + stm >= 2.3 && < 2.5, + time > 1.4 && < 1.5, + 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 + main-is: TestSupervisor.hs + other-modules: TestUtils + diff --git a/src/Control/Distributed/Process/Supervisor.hs b/src/Control/Distributed/Process/Supervisor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Supervisor.hs @@ -0,0 +1,1619 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverlappingInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Supervisor +-- Copyright : (c) Tim Watson 2012 - 2013 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module implements a process which supervises a set of other +-- processes, referred to as its children. These /child processes/ can be +-- either workers (i.e., processes that do something useful in your application) +-- or other supervisors. In this way, supervisors may be used to build a +-- 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. +-- +-- [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 +-- 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. +-- +-- [Restart Strategies] +-- +-- Supervisors are initialised with a 'RestartStrategy', which describes how +-- the supervisor should respond to a child that exits and should be restarted +-- (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. +-- +-- With the exception of the @RestartOne@ strategy, which indicates that the +-- supervisor will restart /only/ the one individual failing child, each +-- strategy describes a way to select the set of children that should be +-- restarted if /any/ child fails. The @RestartAll@ strategy, as its name +-- suggests, selects /all/ children, whilst the @RestartLeft@ and @RestartRight@ +-- strategies select /all/ children to the left or right of the failed child, +-- in insertion (i.e., startup) order. +-- +-- Note that a /branch/ restart will only occur if the child that exited is +-- meant to be restarted. Since @Temporary@ children are never restarted and +-- @Transient@ children are /not/ restarted if they exit normally, in both these +-- circumstances we leave the remaining supervised children alone. Otherwise, +-- the failing child is /always/ included in the /branch/ to be restarted. +-- +-- For a hypothetical set of children @a@ through @d@, the following pseudocode +-- demonstrates how the restart strategies work. +-- +-- > let children = [a..d] +-- > let failure = c +-- > restartsFor RestartOne children failure = [c] +-- > restartsFor RestartAll children failure = [a,b,c,d] +-- > restartsFor RestartLeft children failure = [a,b,c] +-- > restartsFor RestartRight children failure = [c,d] +-- +-- [Branch Restarts] +-- +-- We refer to a restart (strategy) that involves a set of children as a +-- /branch restart/ from now on. The behaviour of branch restarts can be further +-- refined by the 'RestartMode' with which a 'RestartStrategy' is parameterised. +-- The @RestartEach@ mode treats each child sequentially, first stopping the +-- respective child process and then restarting it. Each child is stopped and +-- started fully before moving on to the next, as the following imaginary +-- example demonstrates for children @[a,b,c]@: +-- +-- > stop a +-- > start a +-- > stop b +-- > start b +-- > stop c +-- > start c +-- +-- By contrast, @RestartInOrder@ will first run through the selected list of +-- children, stopping them. Then, once all the children have been stopped, it +-- will make a second pass, to handle (re)starting them. No child is started +-- until all children have been stopped, as the following imaginary example +-- demonstrates: +-- +-- > stop a +-- > stop b +-- > stop c +-- > start a +-- > start b +-- > start c +-- +-- Both the previous examples have shown children being stopped and started +-- from left to right, but that is up to the user. The 'RestartMode' data +-- type's constructors take a 'RestartOrder', which determines whether the +-- selected children will be processed from @LeftToRight@ or @RightToLeft@. +-- +-- Sometimes it is desireable to stop children in one order and start them +-- in the opposite. This is typically the case when children are in some +-- way dependent on one another, such that restarting them in the wrong order +-- might cause the system to misbehave. For this scenarios, there is another +-- 'RestartMode' that will shut children down in the given order, but then +-- restarts them in the reverse. Using @RestartRevOrder@ mode, if we have +-- children @[a,b,c]@ such that @b@ depends on @a@ and @c@ on @b@, we can stop +-- them in the reverse of their startup order, but restart them the other way +-- around like so: +-- +-- > RestartRevOrder RightToLeft +-- +-- The effect will be thus: +-- +-- > stop c +-- > stop b +-- > stop a +-- > start a +-- > start b +-- > start c +-- +-- [Restart Intensity Limits] +-- +-- If a child process repeatedly crashes during (or shortly after) starting, +-- it is possible for the supervisor to get stuck in an endless loop of +-- 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 +-- reason @ExitOther "ReachedMaxRestartIntensity"@. +-- +-- The 'MaxRestarts' type is a positive integer, and together with a specified +-- @TimeInterval@ forms the 'RestartLimit' to which the supervisor will adhere. +-- Since a great many children can be restarted in close succession when +-- a /branch restart/ occurs (as a result of @RestartAll@, @RestartLeft@ or +-- @RestartRight@ being triggered), the supervisor will track the operation +-- as a single restart attempt, since otherwise it would likely exceed its +-- maximum restart intensity too quickly. +-- +-- [Child Restart and Termination 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 +-- 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' +-- provided with the 'ChildSpec' determines how the supervisor should go +-- about doing so. If this is @TerminateImmediately@, 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 +-- 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 +-- occur during a timed-out shutdown will be logged, however exit reasons +-- resulting from @TerminateImmediately@ 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 +-- 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. +-- +-- [Supervision Trees & Supervisor Termination] +-- +-- 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 +-- deep, and it is for this reason that we recommend giving a @Supervisor@ child +-- an arbitrary length of time to stop, by setting the delay to @Infinity@ +-- or a very large @TimeInterval@. +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Supervisor + ( -- * Defining and Running a Supervisor + ChildSpec(..) + , ChildKey + , ChildType(..) + , ChildTerminationPolicy(..) + , ChildStart(..) + , RegisteredName(LocalName, CustomRegister) + , RestartPolicy(..) +-- , ChildRestart(..) + , ChildRef(..) + , isRunning + , isRestarting + , Child + , StaticLabel + , SupervisorPid + , ChildPid + , StarterPid + , ToChildStart(..) + , start + , run + -- * Limits and Defaults + , MaxRestarts + , maxRestarts + , RestartLimit(..) + , limit + , defaultLimits + , RestartMode(..) + , RestartOrder(..) + , RestartStrategy(..) + , ShutdownMode(..) + , restartOne + , restartAll + , restartLeft + , restartRight + -- * Adding and Removing Children + , addChild + , AddChildResult(..) + , StartChildResult(..) + , startChild + , startNewChild + , terminateChild + , TerminateChildResult(..) + , deleteChild + , DeleteChildResult(..) + , restartChild + , RestartChildResult(..) + -- * Normative Shutdown + , shutdown + , shutdownAndWait + -- * Queries and Statistics + , lookupChild + , listChildren + , SupervisorStats(..) + , statistics + -- * Additional (Misc) Types + , StartFailure(..) + , ChildInitFailure(..) + ) where + +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.Extras.Internal.Primitives hiding (monitor) +import Control.Distributed.Process.Extras.Internal.Types + ( ExitReason(..) + ) +import Control.Distributed.Process.ManagedProcess + ( handleCall + , handleInfo + , reply + , continue + , stop + , stopWith + , input + , defaultProcess + , prioritised + , InitHandler + , InitResult(..) + , ProcessAction + , ProcessReply + , ProcessDefinition(..) + , PrioritisedProcessDefinition(..) + , Priority(..) + , DispatchPriority + , UnhandledMessagePolicy(Drop) + ) +import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe + ( call + , cast + ) +import qualified Control.Distributed.Process.ManagedProcess as MP + ( pserve + ) +import Control.Distributed.Process.ManagedProcess.Server.Priority + ( prioritiseCast_ + , prioritiseCall_ + , prioritiseInfo_ + , setPriority + ) +import Control.Distributed.Process.ManagedProcess.Server.Restricted + ( RestrictedProcess + , Result + , RestrictedAction + , getState + , putState + ) +import qualified Control.Distributed.Process.ManagedProcess.Server.Restricted as Restricted + ( handleCallIf + , handleCall + , handleCast + , reply + , continue + ) +import Control.Distributed.Process.Extras.SystemLog + ( LogClient + , LogChan + , LogText + , Logger(..) + ) +import qualified Control.Distributed.Process.Extras.SystemLog as Log +import Control.Distributed.Process.Extras.Time +import Control.Exception (SomeException, throwIO) + +import Control.Monad.Error + +import Data.Accessor + ( Accessor + , accessor + , (^:) + , (.>) + , (^=) + , (^.) + ) +import Data.Binary +import Data.Foldable (find, foldlM, toList) +import Data.List (foldl') +import qualified Data.List as List (delete) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Sequence + ( Seq + , ViewL(EmptyL, (:<)) + , ViewR(EmptyR, (:>)) + , (<|) + , (|>) + , (><) + , filter) +import qualified Data.Sequence as Seq +import Data.Time.Clock + ( NominalDiffTime + , UTCTime + , getCurrentTime + , diffUTCTime + ) +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 + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-- TODO: ToChildStart belongs with rest of types in +-- Control.Distributed.Process.Supervisor.Types + +-- | A type that can be converted to a 'ChildStart'. +class ToChildStart a where + toChildStart :: a -> Process ChildStart + +instance ToChildStart (Closure (Process ())) where + toChildStart = return . RunClosure + +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 + +-- internal APIs. The corresponding XxxResult types are in +-- Control.Distributed.Process.Supervisor.Types + +data DeleteChild = DeleteChild !ChildKey + deriving (Typeable, Generic) +instance Binary DeleteChild where +instance NFData DeleteChild where + +data FindReq = FindReq ChildKey + deriving (Typeable, Generic) +instance Binary FindReq where +instance NFData FindReq where + +data StatsReq = StatsReq + deriving (Typeable, Generic) +instance Binary StatsReq where +instance NFData StatsReq where + +data ListReq = ListReq + deriving (Typeable, Generic) +instance Binary ListReq where +instance NFData ListReq where + +type ImmediateStart = Bool + +data AddChildReq = AddChild !ImmediateStart !ChildSpec + deriving (Typeable, Generic, Show) +instance Binary AddChildReq where +instance NFData AddChildReq where + +data AddChildRes = Exists ChildRef | Added State + +data StartChildReq = StartChild !ChildKey + deriving (Typeable, Generic) +instance Binary StartChildReq where +instance NFData StartChildReq where + +data RestartChildReq = RestartChildReq !ChildKey + deriving (Typeable, Generic, Show, Eq) +instance Binary RestartChildReq where +instance NFData RestartChildReq where + +{- +data DelayedRestartReq = DelayedRestartReq !ChildKey !DiedReason + deriving (Typeable, Generic, Show, Eq) +instance Binary DelayedRestartReq where +-} + +data TerminateChildReq = TerminateChildReq !ChildKey + deriving (Typeable, Generic, Show, Eq) +instance Binary TerminateChildReq where +instance NFData TerminateChildReq where + +data IgnoreChildReq = IgnoreChildReq !ChildPid + deriving (Typeable, Generic) +instance Binary IgnoreChildReq where +instance NFData IgnoreChildReq where + +type ChildSpecs = Seq Child +type Prefix = ChildSpecs +type Suffix = ChildSpecs + +data StatsType = Active | Specified + +data LogSink = LogProcess !LogClient | LogChan + +instance Logger LogSink where + logMessage LogChan = logMessage Log.logChannel + logMessage (LogProcess client') = logMessage client' + +data State = State { + _specs :: ChildSpecs + , _active :: Map ChildPid ChildKey + , _strategy :: RestartStrategy + , _restartPeriod :: NominalDiffTime + , _restarts :: [UTCTime] + , _stats :: SupervisorStats + , _logger :: LogSink + , shutdownStrategy :: ShutdownMode + } + +-------------------------------------------------------------------------------- +-- Starting/Running Supervisor -- +-------------------------------------------------------------------------------- + +-- | Start a supervisor (process), running the supplied children and restart +-- strategy. +-- +-- > start = spawnLocal . run +-- +start :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process SupervisorPid +start rs ss cs = spawnLocal $ run rs ss cs + +-- | Run the supplied children using the provided restart strategy. +-- +run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process () +run rs ss specs' = MP.pserve (rs, ss, specs') supInit serverDefinition + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Obtain statistics about a running supervisor. +-- +statistics :: Addressable a => a -> Process (SupervisorStats) +statistics = (flip Unsafe.call) StatsReq + +-- | Lookup a possibly supervised child, given its 'ChildKey'. +-- +lookupChild :: Addressable a => a -> ChildKey -> Process (Maybe (ChildRef, ChildSpec)) +lookupChild addr key = Unsafe.call addr $ FindReq key + +-- | List all know (i.e., configured) children. +-- +listChildren :: Addressable a => a -> Process [Child] +listChildren addr = Unsafe.call addr ListReq + +-- | Add a new child. +-- +addChild :: Addressable a => a -> ChildSpec -> Process AddChildResult +addChild addr spec = Unsafe.call addr $ AddChild False spec + +-- | Start an existing (configured) child. The 'ChildSpec' must already be +-- present (see 'addChild'), otherwise the operation will fail. +-- +startChild :: Addressable a => a -> ChildKey -> Process StartChildResult +startChild addr key = Unsafe.call addr $ StartChild key + +-- | Atomically add and start a new child spec. Will fail if a child with +-- the given key is already present. +-- +startNewChild :: Addressable a + => a + -> ChildSpec + -> Process AddChildResult +startNewChild addr spec = Unsafe.call addr $ AddChild True spec + +-- | Delete a supervised child. The child must already be stopped (see +-- 'terminateChild'). +-- +deleteChild :: Addressable a => a -> ChildKey -> Process DeleteChildResult +deleteChild sid childKey = Unsafe.call sid $ DeleteChild childKey + +-- | Terminate a running child. +-- +terminateChild :: Addressable a + => a + -> ChildKey + -> Process TerminateChildResult +terminateChild sid = Unsafe.call sid . TerminateChildReq + +-- | Forcibly restart a running child. +-- +restartChild :: Addressable a + => a + -> ChildKey + -> Process RestartChildResult +restartChild sid = Unsafe.call sid . RestartChildReq + +-- | Gracefully terminate a running supervisor. Returns immediately if the +-- /address/ cannot be resolved. +-- +shutdown :: Resolvable a => a -> Process () +shutdown sid = do + mPid <- resolve sid + case mPid of + Nothing -> return () + Just p -> exit p ExitShutdown + +-- | As 'shutdown', but waits until the supervisor process has exited, at which +-- point the caller can be sure that all children have also stopped. Returns +-- immediately if the /address/ cannot be resolved. +-- +shutdownAndWait :: Resolvable a => a -> Process () +shutdownAndWait sid = do + mPid <- resolve sid + case mPid of + Nothing -> return () + Just p -> withMonitor p $ do + shutdown p + receiveWait [ matchIf (\(ProcessMonitorNotification _ p' _) -> p' == p) + (\_ -> return ()) + ] + +-------------------------------------------------------------------------------- +-- Server Initialisation/Startup -- +-------------------------------------------------------------------------------- + +supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State +supInit (strategy', shutdown', specs') = do + logClient <- Log.client + let client' = case logClient of + Nothing -> LogChan + Just c -> LogProcess c + let initState = ( ( -- as a NominalDiffTime (in seconds) + restartPeriod ^= configuredRestartPeriod + ) + . (strategy ^= strategy') + . (logger ^= client') + $ emptyState shutdown' + ) + -- TODO: should we return Ignore, as per OTP's supervisor, if no child starts? + catch (foldlM initChild initState specs' >>= return . (flip InitOk) Infinity) + (\(e :: SomeException) -> do + sup <- getSelfPid + logEntry Log.error $ + mkReport "Could not init supervisor " sup "noproc" (show e) + return $ InitStop (show e)) + where + initChild :: State -> ChildSpec -> Process State + initChild st ch = + case (findChild (childKey ch) st) of + Just (ref, _) -> die $ StartFailureDuplicateChild ref + Nothing -> tryStartChild ch >>= initialised st ch + + configuredRestartPeriod = + let maxT' = maxT (intensity strategy') + tI = asTimeout maxT' + tMs = (fromIntegral tI * (0.000001 :: Float)) + in fromRational (toRational tMs) :: NominalDiffTime + +initialised :: State + -> ChildSpec + -> Either StartFailure ChildRef + -> Process State +initialised _ _ (Left err) = liftIO $ throwIO $ ChildInitFailure (show err) +initialised state spec (Right ref) = do + mPid <- resolve ref + case mPid of + Nothing -> die $ (childKey spec) ++ ": InvalidChildRef" + Just childPid -> do + return $ ( (active ^: Map.insert childPid chId) + . (specs ^: (|> (ref, spec))) + $ bumpStats Active chType (+1) state + ) + where chId = childKey spec + chType = childType spec + +-------------------------------------------------------------------------------- +-- Server Definition/State -- +-------------------------------------------------------------------------------- + +emptyState :: ShutdownMode -> State +emptyState strat = State { + _specs = Seq.empty + , _active = Map.empty + , _strategy = restartAll + , _restartPeriod = (fromIntegral (0 :: Integer)) :: NominalDiffTime + , _restarts = [] + , _stats = emptyStats + , _logger = LogChan + , shutdownStrategy = strat + } + +emptyStats :: SupervisorStats +emptyStats = SupervisorStats { + _children = 0 + , _workers = 0 + , _supervisors = 0 + , _running = 0 + , _activeSupervisors = 0 + , _activeWorkers = 0 + , totalRestarts = 0 +-- , avgRestartFrequency = 0 + } + +serverDefinition :: PrioritisedProcessDefinition State +serverDefinition = prioritised processDefinition supPriorities + where + supPriorities :: [DispatchPriority State] + supPriorities = [ + prioritiseCast_ (\(IgnoreChildReq _) -> setPriority 100) + , prioritiseInfo_ (\(ProcessMonitorNotification _ _ _) -> setPriority 99 ) +-- , prioritiseCast_ (\(DelayedRestartReq _ _) -> setPriority 80 ) + , prioritiseCall_ (\(_ :: FindReq) -> + (setPriority 10) :: Priority (Maybe (ChildRef, ChildSpec))) + ] + +processDefinition :: ProcessDefinition State +processDefinition = + defaultProcess { + apiHandlers = [ + Restricted.handleCast handleIgnore + -- adding, removing and (optionally) starting new child specs + , handleCall handleTerminateChild +-- , handleCast handleDelayedRestart + , Restricted.handleCall handleDeleteChild + , Restricted.handleCallIf (input (\(AddChild immediate _) -> not immediate)) + handleAddChild + , handleCall handleStartNewChild + , handleCall handleStartChild + , handleCall handleRestartChild + -- stats/info + , Restricted.handleCall handleLookupChild + , Restricted.handleCall handleListChildren + , Restricted.handleCall handleGetStats + ] + , infoHandlers = [handleInfo handleMonitorSignal] + , shutdownHandler = handleShutdown + , unhandledMessagePolicy = Drop + } :: ProcessDefinition State + +-------------------------------------------------------------------------------- +-- API Handlers -- +-------------------------------------------------------------------------------- + +handleLookupChild :: FindReq + -> RestrictedProcess State (Result (Maybe (ChildRef, ChildSpec))) +handleLookupChild (FindReq key) = getState >>= Restricted.reply . findChild key + +handleListChildren :: ListReq + -> RestrictedProcess State (Result [Child]) +handleListChildren _ = getState >>= Restricted.reply . toList . (^. specs) + +handleAddChild :: AddChildReq + -> RestrictedProcess State (Result AddChildResult) +handleAddChild req = getState >>= return . doAddChild req True >>= doReply + where doReply :: AddChildRes -> RestrictedProcess State (Result AddChildResult) + doReply (Added s) = putState s >> Restricted.reply (ChildAdded ChildStopped) + doReply (Exists e) = Restricted.reply (ChildFailedToStart $ StartFailureDuplicateChild e) + +handleIgnore :: IgnoreChildReq + -> RestrictedProcess State RestrictedAction +handleIgnore (IgnoreChildReq childPid) = do + {- not only must we take this child out of the `active' field, + we also delete the child spec if it's restart type is Temporary, + since restarting Temporary children is dis-allowed -} + state <- getState + let (cId, active') = + Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active + case cId of + Nothing -> Restricted.continue + Just c -> do + putState $ ( (active ^= active') + . (resetChildIgnored c) + $ state + ) + Restricted.continue + where + resetChildIgnored :: ChildKey -> State -> State + resetChildIgnored key state = + maybe state id $ updateChild key (setChildStopped True) state + +handleDeleteChild :: DeleteChild + -> RestrictedProcess State (Result DeleteChildResult) +handleDeleteChild (DeleteChild k) = getState >>= handleDelete k + where + handleDelete :: ChildKey + -> State + -> RestrictedProcess State (Result DeleteChildResult) + handleDelete key state = + let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs + in case (Seq.viewl suffix) of + EmptyL -> Restricted.reply ChildNotFound + child :< remaining -> tryDeleteChild child prefix remaining state + + tryDeleteChild (ref, spec) pfx sfx st + | ref == ChildStopped = do + putState $ ( (specs ^= pfx >< sfx) + $ bumpStats Specified (childType spec) decrement st + ) + Restricted.reply ChildDeleted + | otherwise = Restricted.reply $ ChildNotStopped ref + +handleStartChild :: State + -> StartChildReq + -> Process (ProcessReply StartChildResult State) +handleStartChild state (StartChild key) = + let child = findChild key state in + case child of + Nothing -> + reply ChildStartUnknownId state + Just (ref@(ChildRunning _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRunningExtra _ _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRestarting _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (_, spec) -> do + started <- doStartChild spec state + case started of + Left err -> reply (ChildStartFailed err) state + Right (ref, st') -> reply (ChildStartOk ref) st' + +handleStartNewChild :: State + -> AddChildReq + -> Process (ProcessReply AddChildResult State) +handleStartNewChild state req@(AddChild _ spec) = + let added = doAddChild req False state in + case added of + Exists e -> reply (ChildFailedToStart $ StartFailureDuplicateChild e) state + Added _ -> attemptStart state spec + where + attemptStart st ch = do + started <- tryStartChild ch + case started of + Left err -> reply (ChildFailedToStart err) $ removeChild spec st -- TODO: document this! + Right ref -> do + let st' = ( (specs ^: (|> (ref, spec))) + $ bumpStats Specified (childType spec) (+1) st + ) + in reply (ChildAdded ref) $ markActive st' ref ch + +handleRestartChild :: State + -> RestartChildReq + -> Process (ProcessReply RestartChildResult State) +handleRestartChild state (RestartChildReq key) = + let child = findChild key state in + case child of + Nothing -> + reply ChildRestartUnknownId state + Just (ref@(ChildRunning _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRunningExtra _ _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRestarting _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (_, spec) -> do + started <- doStartChild spec state + case started of + Left err -> reply (ChildRestartFailed err) state + Right (ref, st') -> reply (ChildRestartOk ref) st' + +{- +handleDelayedRestart :: State + -> DelayedRestartReq + -> Process (ProcessAction State) +handleDelayedRestart state (DelayedRestartReq key reason) = + let child = findChild key state in + case child of + Nothing -> + continue state -- a child could've been terminated 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 +-} + +handleTerminateChild :: State + -> TerminateChildReq + -> Process (ProcessReply TerminateChildResult State) +handleTerminateChild state (TerminateChildReq key) = + let child = findChild key state in + case child of + Nothing -> + reply TerminateChildUnknownId state + Just (ChildStopped, _) -> + reply TerminateChildOk state + Just (ref, spec) -> + reply TerminateChildOk =<< doTerminateChild ref spec state + +handleGetStats :: StatsReq + -> RestrictedProcess State (Result SupervisorStats) +handleGetStats _ = Restricted.reply . (^. stats) =<< getState + +-------------------------------------------------------------------------------- +-- Child Monitoring -- +-------------------------------------------------------------------------------- + +handleMonitorSignal :: State + -> ProcessMonitorNotification + -> Process (ProcessAction State) +handleMonitorSignal state (ProcessMonitorNotification _ childPid reason) = do + let (cId, active') = + Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active + let mSpec = + case cId of + Nothing -> Nothing + Just c -> fmap snd $ findChild c state + case mSpec of + Nothing -> continue $ (active ^= active') state + Just spec -> tryRestart childPid state active' spec reason + +-------------------------------------------------------------------------------- +-- Child Monitoring -- +-------------------------------------------------------------------------------- + +handleShutdown :: State -> ExitReason -> Process () +handleShutdown state (ExitOther reason) = terminateChildren state >> die reason +handleShutdown state _ = terminateChildren state + +-------------------------------------------------------------------------------- +-- Child Start/Restart Handling -- +-------------------------------------------------------------------------------- + +tryRestart :: ChildPid + -> State + -> Map ChildPid ChildKey + -> ChildSpec + -> DiedReason + -> Process (ProcessAction State) +tryRestart childPid state active' spec reason = do + sup <- getSelfPid + logEntry Log.debug $ do + mkReport "tryRestart" sup (childKey spec) (show reason) + case state ^. strategy of + RestartOne _ -> tryRestartChild childPid state active' spec reason + strat -> do + case (childRestart spec, isNormal reason) of + (Intrinsic, True) -> stopWith newState ExitNormal + (Transient, True) -> continue newState + (Temporary, _) -> continue removeTemp + _ -> tryRestartBranch strat spec reason $ newState + where + newState = (active ^= active') state + + removeTemp = removeChild spec $ newState + + isNormal (DiedException _) = False + isNormal _ = True + +tryRestartBranch :: RestartStrategy + -> ChildSpec + -> DiedReason + -> State + -> Process (ProcessAction State) +tryRestartBranch rs sp dr st = -- TODO: use DiedReason for logging... + let mode' = mode rs + tree' = case rs of + RestartAll _ _ -> childSpecs + RestartLeft _ _ -> subTreeL + RestartRight _ _ -> subTreeR + _ -> error "IllegalState" + proc = case mode' of + RestartEach _ -> stopStart + RestartInOrder _ -> restartL + RestartRevOrder _ -> reverseRestart + dir' = order mode' in do + proc tree' dir' + where + stopStart :: ChildSpecs -> RestartOrder -> Process (ProcessAction State) + stopStart tree order' = do + let tree' = case order' of + LeftToRight -> tree + RightToLeft -> Seq.reverse tree + state <- addRestart activeState + case state of + Nothing -> die errorMaxIntensityReached + 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 + state <- addRestart activeState + case state of + Nothing -> die errorMaxIntensityReached + Just st' -> foldlM stopIt st' tree >>= \s -> do + apply $ foldlM startIt s tree' + + stopStartIt :: State -> Child -> Process State + stopStartIt s ch@(cr, cs) = doTerminateChild cr cs s >>= (flip startIt) ch + + stopIt :: State -> Child -> Process State + stopIt s (cr, cs) = doTerminateChild cr cs s + + startIt :: State -> Child -> Process State + startIt s (_, cs) + | isTemporary (childRestart cs) = return $ removeChild cs s + | otherwise = ensureActive cs =<< doStartChild cs s + + -- Note that ensureActive will kill this (supervisor) process if + -- doStartChild fails, simply because the /only/ failure that can + -- come out of that function (as `Left err') is *bad closure* and + -- that should have either been picked up during init (i.e., caused + -- the super to refuse to start) or been removed during `startChild' + -- or later on. Any other kind of failure will crop up (once we've + -- finished the restart sequence) as a monitor signal. + ensureActive :: ChildSpec + -> Either StartFailure (ChildRef, State) + -> Process State + ensureActive cs it + | (Right (ref, st')) <- it = return $ markActive st' ref cs + | (Left err) <- it = die $ ExitOther $ (childKey cs) ++ ": " ++ (show err) + | otherwise = error "IllegalState" + + apply :: (Process State) -> Process (ProcessAction State) + apply proc = do + catchExit (proc >>= continue) (\(_ :: ProcessId) -> stop) + + activeState = maybe st id $ updateChild (childKey sp) + (setChildStopped False) st + + subTreeL :: ChildSpecs + subTreeL = + let (prefix, suffix) = splitTree Seq.breakl + in case (Seq.viewl suffix) of + child :< _ -> prefix |> child + EmptyL -> prefix + + subTreeR :: ChildSpecs + subTreeR = + let (prefix, suffix) = splitTree Seq.breakr + in case (Seq.viewr suffix) of + _ :> child -> child <| prefix + EmptyR -> prefix + + splitTree splitWith = splitWith ((== childKey sp) . childKey . snd) childSpecs + + childSpecs :: ChildSpecs + childSpecs = + let cs = activeState ^. specs + ck = childKey sp + rs' = childRestart sp + in case (isTransient rs', isTemporary rs', dr) of + (True, _, DiedNormal) -> filter ((/= ck) . childKey . snd) cs + (_, True, _) -> filter ((/= ck) . childKey . snd) cs + _ -> cs + +{- restartParallel :: ChildSpecs + -> RestartOrder + -> Process (ProcessAction State) + restartParallel tree order = do + liftIO $ putStrLn "handling parallel restart" + let tree' = case order of + LeftToRight -> tree + RightToLeft -> Seq.reverse tree + + -- TODO: THIS IS INCORRECT... currently (below), we terminate + -- 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 + (_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 + mPid <- resolve cr + case mPid of + Nothing -> return Nothing + Just childPid -> do + void $ doTerminateChild cr cs activeState + return $ Just (childKey cs, childPid) + + collectExits :: ([ExitReason], State) + -> Async (Maybe (ChildKey, ChildPid)) + -> Process ([ExitReason], State) + collectExits (errs, state) hAsync = do + -- we perform a blocking wait on each handle, since we'll + -- always wait until the last shutdown has occurred anyway + asyncResult <- wait hAsync + let res = mergeState asyncResult state + case res of + Left err -> return ((err:errs), state) + Right st -> return (errs, st) + + mergeState :: AsyncResult (Maybe (ChildKey, ChildPid)) + -> State + -> Either ExitReason State + mergeState (AsyncDone Nothing) state = Right state + mergeState (AsyncDone (Just (key, childPid))) state = Right $ mergeIt key childPid state + mergeState (AsyncFailed r) _ = Left $ ExitOther (show r) + mergeState (AsyncLinkFailed r) _ = Left $ ExitOther (show r) + mergeState _ _ = Left $ ExitOther "IllegalState" + + mergeIt :: ChildKey -> ChildPid -> State -> State + mergeIt key childPid state = + -- TODO: lookup the old ref -> childPid and delete from the active map + ( (active ^: Map.delete childPid) + $ maybe state id (updateChild key (setChildStopped False) state) + ) + -} + +tryRestartChild :: ChildPid + -> State + -> Map ChildPid ChildKey + -> ChildSpec + -> DiedReason + -> Process (ProcessAction State) +tryRestartChild childPid st active' spec reason + | DiedNormal <- reason + , True <- isTransient (childRestart spec) = continue childDown + | True <- isTemporary (childRestart spec) = continue childRemoved + | DiedNormal <- reason + , True <- isIntrinsic (childRestart spec) = stopWith updateStopped ExitNormal + | otherwise = doRestartChild childPid spec reason st + where + childDown = (active ^= active') $ updateStopped + childRemoved = (active ^= active') $ removeChild spec st + updateStopped = maybe st id $ updateChild chKey (setChildStopped False) st + chKey = childKey spec + +doRestartChild :: ChildPid -> ChildSpec -> DiedReason -> State -> Process (ProcessAction State) +doRestartChild _ spec _ 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 + Just st -> do + start' <- doStartChild spec st + case start' of + Right (ref, st') -> continue $ markActive st' ref spec + Left err -> do + -- All child failures are handled via monitor signals, apart from + -- 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 $ + mkReport "Error in temporary child" sup (childKey spec) (show err) + continue $ ( (active ^: Map.filter (/= chKey)) + . (bumpStats Active chType decrement) + . (bumpStats Specified chType decrement) + $ removeChild spec st) + else do + logEntry Log.error $ + 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 +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) + ) + where + chKey = childKey spec + chType = childType spec +-} + +addRestart :: State -> Process (Maybe State) +addRestart state = do + now <- liftIO $ getCurrentTime + let acc = foldl' (accRestarts now) [] (now:restarted) + case length acc of + n | n > maxAttempts -> return Nothing + _ -> return $ Just $ (restarts ^= acc) $ state + where + maxAttempts = maxNumberOfRestarts $ maxR $ maxIntensity + slot = state ^. restartPeriod + restarted = state ^. restarts + maxIntensity = state ^. strategy .> restartIntensity + + accRestarts :: UTCTime -> [UTCTime] -> UTCTime -> [UTCTime] + accRestarts now' acc r = + let diff = diffUTCTime now' r in + if diff > slot then acc else (r:acc) + +doStartChild :: ChildSpec + -> State + -> Process (Either StartFailure (ChildRef, State)) +doStartChild spec st = do + restart <- tryStartChild spec + case restart of + Left f -> return $ Left f + Right p -> do + 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 + Just s' -> return $ Right $ (p, markActive s' p spec) + where + chKey = childKey spec + + chRunning :: ChildRef -> Child -> Prefix -> Suffix -> State -> Maybe State + chRunning newRef (_, chSpec) prefix suffix st' = + Just $ ( (specs ^= prefix >< ((newRef, chSpec) <| suffix)) + $ bumpStats Active (childType spec) (+1) st' + ) + +tryStartChild :: ChildSpec + -> Process (Either StartFailure ChildRef) +tryStartChild ChildSpec{..} = + case childStart of + RunClosure proc -> do + -- TODO: cache your closures!!! + mProc <- catch (unClosure proc >>= return . Right) + (\(e :: SomeException) -> return $ Left (show e)) + case mProc of + Left err -> logStartFailure $ StartFailureBadClosure err + Right p -> wrapClosure 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 + where + logStartFailure sf = do + sup <- getSelfPid + logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf) + return $ Left sf + + wrapClosure :: Maybe RegisteredName + -> Process () + -> Process ChildRef + wrapClosure regName proc = do + supervisor <- getSelfPid + childPid <- spawnLocal $ do + self <- getSelfPid + link supervisor -- die if our parent dies + 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 ]) + `catchesExit` [ + (\_ m -> handleMessageIf m (== ExitShutdown) + (\_ -> return ()))] + void $ monitor childPid + send childPid () + return $ ChildRunning childPid + + wrapHandle :: Maybe RegisteredName + -> (SupervisorPid -> Process (ChildPid, Message)) + -> Process ChildRef + wrapHandle 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 :: 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) + (\(e :: SomeException) -> return $ Left (show e)) + case mProc of + Left err -> die $ ExitOther (show err) + Right p -> p pid + +filterInitFailures :: SupervisorPid + -> ChildPid + -> ChildInitFailure + -> Process () +filterInitFailures sup childPid ex = do + case ex of + ChildInitFailure _ -> do + -- This is used as a `catches` handler in multiple places + -- 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) + liftIO $ throwIO ex + ChildInitIgnore -> Unsafe.cast sup $ IgnoreChildReq childPid + +-------------------------------------------------------------------------------- +-- Child Termination/Shutdown -- +-------------------------------------------------------------------------------- + +terminateChildren :: State -> Process () +terminateChildren state = do + case (shutdownStrategy state) 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 + case terminationErrors of + [] -> return () + _ -> do + sup <- getSelfPid + void $ logEntry Log.error $ + mkReport "Errors in terminateChildren / 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) + where + syncTerminate :: Child -> State -> Process State + syncTerminate (cr, cs) state' = doTerminateChild cr cs state' + + collectExits :: [(ProcessId, DiedReason)] + -> [ChildPid] + -> Process [(ProcessId, DiedReason)] + collectExits errors [] = return errors + collectExits errors pids = do + (pid, reason) <- receiveWait [ + match (\(ProcessMonitorNotification _ pid' reason') -> do + return (pid', reason')) + ] + let remaining = List.delete pid pids + case reason of + DiedNormal -> collectExits errors remaining + _ -> collectExits ((pid, reason):errors) remaining + +doTerminateChild :: ChildRef -> ChildSpec -> State -> Process State +doTerminateChild ref spec state = do + 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 + return $ ( (active ^: Map.delete pid) + $ state' + ) + 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' + + chKey = childKey spec + updateStopped = maybe state id $ updateChild chKey (setChildStopped False) state + +childShutdown :: ChildTerminationPolicy + -> ChildPid + -> State + -> Process DiedReason +childShutdown policy childPid st = do + case policy of + (TerminateTimeout t) -> exit childPid ExitShutdown >> await childPid t st + -- we ignore DiedReason for brutal kills + TerminateImmediately -> do + kill childPid "TerminatedBySupervisor" + void $ await 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') + -- 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 + + matches :: ChildPid -> [Match DiedReason] + matches p = [ + matchIf (\(ProcessMonitorNotification _ p' _) -> p == p') + (\(ProcessMonitorNotification _ _ r) -> return r) + ] + +-------------------------------------------------------------------------------- +-- Loging/Reporting -- +-------------------------------------------------------------------------------- + +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 + +logFailure :: SupervisorPid -> ChildPid -> SomeException -> Process () +logFailure sup childPid ex = do + logEntry Log.notice $ mkReport "Detected Child Exit" sup (show childPid) (show ex) + liftIO $ throwIO ex + +logEntry :: (LogChan -> LogText -> Process ()) -> String -> Process () +logEntry lg = Log.report lg Log.logChannel + +mkReport :: String -> SupervisorPid -> String -> String -> String +mkReport b s c r = foldl' (\x xs -> xs ++ " " ++ x) "" items + where + items :: [String] + items = [ "[" ++ s' ++ "]" | s' <- [ b + , "supervisor: " ++ show s + , "child: " ++ c + , "reason: " ++ r] ] + +-------------------------------------------------------------------------------- +-- Accessors and State/Stats Utilities -- +-------------------------------------------------------------------------------- + +type Ignored = Bool + +-- TODO: test that setChildStopped does not re-order the 'specs sequence + +setChildStopped :: Ignored -> Child -> Prefix -> Suffix -> State -> Maybe State +setChildStopped ignored child prefix remaining st = + let spec = snd child + rType = childRestart spec + newRef = if ignored then ChildStartIgnored else ChildStopped + in case isTemporary rType of + 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 +-} + +doAddChild :: AddChildReq -> Bool -> State -> AddChildRes +doAddChild (AddChild _ spec) update st = + let chType = childType spec + in case (findChild (childKey spec) st) of + Just (ref, _) -> Exists ref + Nothing -> + case update of + True -> Added $ ( (specs ^: (|> (ChildStopped, spec))) + $ bumpStats Specified chType (+1) st + ) + False -> Added st + +updateChild :: ChildKey + -> (Child -> Prefix -> Suffix -> State -> Maybe State) + -> State + -> Maybe State +updateChild key updateFn state = + let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs + in case (Seq.viewl suffix) of + EmptyL -> Nothing + child :< remaining -> updateFn child prefix remaining state + +removeChild :: ChildSpec -> State -> State +removeChild spec state = + let k = childKey spec + in specs ^: filter ((/= k) . childKey . snd) $ state + +-- DO NOT call this function unless you've verified the ChildRef first. +markActive :: State -> ChildRef -> ChildSpec -> State +markActive state ref spec = + case ref of + ChildRunning (pid :: ChildPid) -> inserted pid + ChildRunningExtra pid _ -> inserted pid + _ -> error $ "InternalError" + where + inserted pid' = active ^: Map.insert pid' (childKey spec) $ state + +decrement :: Int -> Int +decrement n = n - 1 + +-- this is O(n) in the worst case, which is a bit naff, but we +-- can optimise it later with a different data structure, if required +findChild :: ChildKey -> State -> Maybe (ChildRef, ChildSpec) +findChild key st = find ((== key) . childKey . snd) $ st ^. specs + +bumpStats :: StatsType -> ChildType -> (Int -> Int) -> State -> State +bumpStats Specified Supervisor fn st = (bump fn) . (stats .> supervisors ^: fn) $ st +bumpStats Specified Worker fn st = (bump fn) . (stats .> workers ^: fn) $ st +bumpStats Active Worker fn st = (stats .> running ^: fn) . (stats .> activeWorkers ^: fn) $ st +bumpStats Active Supervisor fn st = (stats .> running ^: fn) . (stats .> activeSupervisors ^: fn) $ st + +bump :: (Int -> Int) -> State -> State +bump with' = stats .> children ^: with' + +isTemporary :: RestartPolicy -> Bool +isTemporary = (== Temporary) + +isTransient :: RestartPolicy -> Bool +isTransient = (== Transient) + +isIntrinsic :: RestartPolicy -> Bool +isIntrinsic = (== Intrinsic) + +active :: Accessor State (Map ChildPid ChildKey) +active = accessor _active (\act' st -> st { _active = act' }) + +strategy :: Accessor State RestartStrategy +strategy = accessor _strategy (\s st -> st { _strategy = s }) + +restartIntensity :: Accessor RestartStrategy RestartLimit +restartIntensity = accessor intensity (\i l -> l { intensity = i }) + +restartPeriod :: Accessor State NominalDiffTime +restartPeriod = accessor _restartPeriod (\p st -> st { _restartPeriod = p }) + +restarts :: Accessor State [UTCTime] +restarts = accessor _restarts (\r st -> st { _restarts = r }) + +specs :: Accessor State ChildSpecs +specs = accessor _specs (\sp' st -> st { _specs = sp' }) + +stats :: Accessor State SupervisorStats +stats = accessor _stats (\st' st -> st { _stats = st' }) + +logger :: Accessor State LogSink +logger = accessor _logger (\l st -> st { _logger = l }) + +children :: Accessor SupervisorStats Int +children = accessor _children (\c st -> st { _children = c }) + +workers :: Accessor SupervisorStats Int +workers = accessor _workers (\c st -> st { _workers = c }) + +running :: Accessor SupervisorStats Int +running = accessor _running (\r st -> st { _running = r }) + +supervisors :: Accessor SupervisorStats Int +supervisors = accessor _supervisors (\c st -> st { _supervisors = c }) + +activeWorkers :: Accessor SupervisorStats Int +activeWorkers = accessor _activeWorkers (\c st -> st { _activeWorkers = c }) + +activeSupervisors :: Accessor SupervisorStats Int +activeSupervisors = accessor _activeSupervisors (\c st -> st { _activeSupervisors = c }) diff --git a/src/Control/Distributed/Process/Supervisor/Types.hs b/src/Control/Distributed/Process/Supervisor/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Supervisor/Types.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Supervisor.Types +-- Copyright : (c) Tim Watson 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Supervisor.Types + ( -- * Defining and Running a Supervisor + ChildSpec(..) + , ChildKey + , ChildType(..) + , ChildTerminationPolicy(..) + , ChildStart(..) + , RegisteredName(LocalName, GlobalName, CustomRegister) + , RestartPolicy(..) + , ChildRef(..) + , isRunning + , isRestarting + , Child + , StaticLabel + , SupervisorPid + , ChildPid + , StarterPid + -- * Limits and Defaults + , MaxRestarts(..) + , maxRestarts + , RestartLimit(..) + , limit + , defaultLimits + , RestartMode(..) + , RestartOrder(..) + , RestartStrategy(..) + , ShutdownMode(..) + , restartOne + , restartAll + , restartLeft + , restartRight + -- * Adding and Removing Children + , AddChildResult(..) + , StartChildResult(..) + , TerminateChildResult(..) + , DeleteChildResult(..) + , RestartChildResult(..) + -- * Additional (Misc) Types + , SupervisorStats(..) + , StartFailure(..) + , ChildInitFailure(..) + ) where + +import GHC.Generics +import Data.Typeable (Typeable) +import Data.Binary + +import Control.DeepSeq (NFData) +import Control.Distributed.Process hiding (call) +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor) +import Control.Exception (Exception) + +-- aliases for api documentation purposes +type SupervisorPid = ProcessId +type ChildPid = ProcessId +type StarterPid = ProcessId + +newtype MaxRestarts = MaxR { maxNumberOfRestarts :: Int } + deriving (Typeable, Generic, Show) +instance Binary MaxRestarts where +instance NFData MaxRestarts where + +-- | Smart constructor for @MaxRestarts@. The maximum +-- restart count must be a positive integer. +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. +-- +data RestartLimit = + RestartLimit + { maxR :: !MaxRestarts + , maxT :: !TimeInterval + } + deriving (Typeable, Generic, Show) +instance Binary RestartLimit where +instance NFData RestartLimit where + +limit :: MaxRestarts -> TimeInterval -> RestartLimit +limit mr = RestartLimit mr + +defaultLimits :: RestartLimit +defaultLimits = limit (MaxR 1) (seconds 1) + +data RestartOrder = LeftToRight | RightToLeft + deriving (Typeable, Generic, Eq, Show) +instance Binary RestartOrder where +instance NFData RestartOrder where + +-- TODO: rename these, somehow... +data RestartMode = + RestartEach { order :: !RestartOrder } + {- ^ stop then start each child sequentially, i.e., @foldlM stopThenStart children@ -} + | RestartInOrder { order :: !RestartOrder } + {- ^ stop all children first, then restart them sequentially -} + | RestartRevOrder { order :: !RestartOrder } + {- ^ stop all children in the given order, but start them in reverse -} + deriving (Typeable, Generic, Show, Eq) +instance Binary RestartMode where +instance NFData RestartMode where + +data ShutdownMode = SequentialShutdown !RestartOrder + | ParallelShutdown + deriving (Typeable, Generic, Show, Eq) +instance Binary ShutdownMode where +instance NFData ShutdownMode where + +-- | Strategy used by a supervisor to handle child restarts, whether due to +-- unexpected child failure or explicit restart requests from a client. +-- +-- Some terminology: We refer to child processes managed by the same supervisor +-- as /siblings/. When restarting a child process, the 'RestartNone' policy +-- indicates that sibling processes should be left alone, whilst the 'RestartAll' +-- policy will cause /all/ children to be restarted (in the same order they were +-- started). +-- +-- 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 +-- without having to resort to grouping them using a child supervisor. +-- +data RestartStrategy = + RestartOne + { intensity :: !RestartLimit + } -- ^ restart only the failed child process + | RestartAll + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ also restart all siblings + | RestartLeft + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ restart prior siblings (i.e., prior /start order/) + | RestartRight + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ restart subsequent siblings (i.e., subsequent /start order/) + deriving (Typeable, Generic, Show) +instance Binary RestartStrategy where +instance NFData RestartStrategy where + +-- | Provides a default 'RestartStrategy' for @RestartOne@. +-- > restartOne = RestartOne defaultLimits +-- +restartOne :: RestartStrategy +restartOne = RestartOne defaultLimits + +-- | Provides a default 'RestartStrategy' for @RestartAll@. +-- > restartOne = RestartAll defaultLimits (RestartEach LeftToRight) +-- +restartAll :: RestartStrategy +restartAll = RestartAll defaultLimits (RestartEach LeftToRight) + +-- | Provides a default 'RestartStrategy' for @RestartLeft@. +-- > restartOne = RestartLeft defaultLimits (RestartEach LeftToRight) +-- +restartLeft :: RestartStrategy +restartLeft = RestartLeft defaultLimits (RestartEach LeftToRight) + +-- | Provides a default 'RestartStrategy' for @RestartRight@. +-- > restartOne = RestartRight defaultLimits (RestartEach LeftToRight) +-- +restartRight :: RestartStrategy +restartRight = RestartRight defaultLimits (RestartEach LeftToRight) + +-- | Identifies a child process by name. +type ChildKey = String + +-- | A reference to a (possibly running) child. +data ChildRef = + ChildRunning !ChildPid -- ^ a reference to the (currently running) child + | ChildRunningExtra !ChildPid !Message -- ^ also a currently running child, with /extra/ child info + | ChildRestarting !ChildPid -- ^ a reference to the /old/ (previous) child (now restarting) + | ChildStopped -- ^ indicates the child is not currently running + | ChildStartIgnored -- ^ a non-temporary child exited with 'ChildInitIgnore' + deriving (Typeable, Generic, Show) +instance Binary ChildRef where +instance NFData ChildRef where + +instance Eq ChildRef where + ChildRunning p1 == ChildRunning p2 = p1 == p2 + ChildRunningExtra p1 _ == ChildRunningExtra p2 _ = p1 == p2 + ChildRestarting p1 == ChildRestarting p2 = p1 == p2 + ChildStopped == ChildStopped = True + ChildStartIgnored == ChildStartIgnored = True + _ == _ = False + +isRunning :: ChildRef -> Bool +isRunning (ChildRunning _) = True +isRunning (ChildRunningExtra _ _) = True +isRunning _ = False + +isRestarting :: ChildRef -> Bool +isRestarting (ChildRestarting _) = True +isRestarting _ = False + +instance Resolvable ChildRef where + resolve (ChildRunning pid) = return $ Just pid + resolve (ChildRunningExtra pid _) = return $ Just pid + resolve _ = return Nothing + +-- these look a bit odd, but we basically want to avoid resolving +-- or sending to (ChildRestarting oldPid) +instance Routable ChildRef where + sendTo (ChildRunning addr) = sendTo addr + sendTo _ = error "invalid address for child process" + + unsafeSendTo (ChildRunning ch) = unsafeSendTo ch + unsafeSendTo _ = error "invalid address for child process" + +-- | Specifies whether the child is another supervisor, or a worker. +data ChildType = Worker | Supervisor + deriving (Typeable, Generic, Show, Eq) +instance Binary ChildType where +instance NFData ChildType where + +-- | Describes when a terminated 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 + | 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 + deriving (Typeable, Generic, Eq, Show) +instance Binary ChildTerminationPolicy where +instance NFData ChildTerminationPolicy where + +data RegisteredName = + LocalName !String + | GlobalName !String + | CustomRegister !(Closure (ChildPid -> Process ())) + deriving (Typeable, Generic) +instance Binary RegisteredName where +instance NFData RegisteredName where + +instance Show RegisteredName where + show (CustomRegister _) = "Custom Register" + show (LocalName n) = n + show (GlobalName n) = "global::" ++ n + +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 + +-- | Specification for a child process. The child must be uniquely identified +-- by it's @childKey@ within the supervisor. The supervisor will start the child +-- itself, therefore @childRun@ should contain the child process' implementation +-- 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) + } deriving (Typeable, Generic, Show) +instance Binary ChildSpec where +instance NFData ChildSpec where + + +data ChildInitFailure = + ChildInitFailure !String + | ChildInitIgnore + deriving (Typeable, Generic, Show) +instance Exception ChildInitFailure where + +data SupervisorStats = SupervisorStats { + _children :: Int + , _supervisors :: Int + , _workers :: Int + , _running :: Int + , _activeSupervisors :: Int + , _activeWorkers :: Int + -- TODO: usage/restart/freq stats + , totalRestarts :: Int + } deriving (Typeable, Generic, Show) +instance Binary SupervisorStats where +instance NFData SupervisorStats where + +-- | Static labels (in the remote table) are strings. +type StaticLabel = String + +-- | Provides failure information when (re-)start failure is indicated. +data StartFailure = + StartFailureDuplicateChild !ChildRef -- ^ a child with this 'ChildKey' already exists + | StartFailureAlreadyRunning !ChildRef -- ^ the child is already up and running + | StartFailureBadClosure !StaticLabel -- ^ a closure cannot be resolved + | StartFailureDied !DiedReason -- ^ a child died (almost) immediately on starting + deriving (Typeable, Generic, Show, Eq) +instance Binary StartFailure where +instance NFData StartFailure where + +-- | The result of a call to 'removeChild'. +data DeleteChildResult = + ChildDeleted -- ^ the child specification was successfully removed + | ChildNotFound -- ^ the child specification was not found + | ChildNotStopped !ChildRef -- ^ the child was not removed, as it was not stopped. + deriving (Typeable, Generic, Show, Eq) +instance Binary DeleteChildResult where +instance NFData DeleteChildResult where + +type Child = (ChildRef, ChildSpec) + +-- exported result types of internal APIs + +data AddChildResult = + ChildAdded !ChildRef + | ChildFailedToStart !StartFailure + deriving (Typeable, Generic, Show, Eq) +instance Binary AddChildResult where +instance NFData AddChildResult where + +data StartChildResult = + ChildStartOk !ChildRef + | ChildStartFailed !StartFailure + | ChildStartUnknownId + | ChildStartInitIgnored + deriving (Typeable, Generic, Show, Eq) +instance Binary StartChildResult where +instance NFData StartChildResult where + +data RestartChildResult = + ChildRestartOk !ChildRef + | ChildRestartFailed !StartFailure + | ChildRestartUnknownId + | ChildRestartIgnored + deriving (Typeable, Generic, Show, Eq) + +instance Binary RestartChildResult where +instance NFData RestartChildResult where + +data TerminateChildResult = + TerminateChildOk + | TerminateChildUnknownId + deriving (Typeable, Generic, Show, Eq) +instance Binary TerminateChildResult where +instance NFData TerminateChildResult where diff --git a/tests/TestSupervisor.hs b/tests/TestSupervisor.hs new file mode 100644 --- /dev/null +++ b/tests/TestSupervisor.hs @@ -0,0 +1,1366 @@ +{-# 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 + diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/TestUtils.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} + +module TestUtils + ( TestResult + -- ping ! + , Ping(Ping) + , ping + , shouldBe + , shouldMatch + , shouldContain + , shouldNotContain + , shouldExitWith + , expectThat + -- test process utilities + , TestProcessControl + , startTestProcess + , runTestProcess + , testProcessGo + , testProcessStop + , testProcessReport + , delayedAssertion + , assertComplete + , waitForExit + -- logging + , Logger() + , newLogger + , putLogMsg + , stopLogger + -- runners + , mkNode + , tryRunProcess + , testMain + , stash + ) where + +#if ! MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif +import Control.Concurrent + ( ThreadId + , myThreadId + , forkIO + ) +import Control.Concurrent.STM + ( TQueue + , newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Concurrent.MVar + ( MVar + , newEmptyMVar + , takeMVar + , putMVar + ) + +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.Extras.Internal.Types +import Control.Exception (SomeException) +import qualified Control.Exception as Exception +import Control.Monad (forever) +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 Control.DeepSeq + +import Network.Transport.TCP +import qualified Network.Transport as NT + +import Data.Binary +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 a r = do + _ <- resolve a + d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ] + d `shouldBe` equalTo r + +waitForExit :: MVar ExitReason + -> Process (Maybe ExitReason) +waitForExit exitReason = do + -- we *might* end up blocked here, so ensure the test doesn't jam up! + self <- getSelfPid + tref <- killAfter (within 10 Seconds) self "testcast timed out" + tr <- liftIO $ takeMVar exitReason + cancelTimer tref + case tr of + ExitNormal -> return Nothing + other -> return $ Just other + +mkNode :: String -> IO LocalNode +mkNode port = do + Right (transport1, _) <- createTransportExposeInternals + "127.0.0.1" port defaultTCPParameters + newLocalNode transport1 initRemoteTable + +-- | Run the supplied @testProc@ using an @MVar@ to collect and assert +-- against its result. Uses the supplied @note@ if the assertion fails. +delayedAssertion :: (Eq a) => String -> LocalNode -> a -> + (TestResult a -> Process ()) -> Assertion +delayedAssertion note localNode expected testProc = do + result <- newEmptyMVar + _ <- forkProcess localNode $ testProc result + assertComplete note result expected + +-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@ +assertComplete :: (Eq a) => String -> MVar a -> a -> IO () +assertComplete msg mv a = do + b <- takeMVar mv + assertBool msg (a == b) + +-- synchronised logging + +data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String } + +-- | Create a new Logger. +-- Logger uses a 'TQueue' to receive and process messages on a worker thread. +newLogger :: IO Logger +newLogger = do + tid <- liftIO $ myThreadId + q <- liftIO $ newTQueueIO + _ <- forkIO $ logger q + return $ Logger tid q + where logger q' = forever $ do + msg <- atomically $ readTQueue q' + putStrLn msg + +-- | Send a message to the Logger +putLogMsg :: Logger -> String -> Process () +putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg + +-- | Stop the worker thread for the given Logger +stopLogger :: Logger -> IO () +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 builder = do + Right (transport, _) <- createTransportExposeInternals + "127.0.0.1" "10501" defaultTCPParameters + testData <- builder transport + defaultMain testData + +-- | Runs a /test process/ around the supplied @proc@, which is executed +-- whenever the outer process loop receives a 'Go' signal. +runTestProcess :: Process () -> Process () +runTestProcess proc = do + ctl <- expect + case ctl of + Stop -> return () + Go -> proc >> runTestProcess proc + Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc + +-- | Starts a test process on the local node. +startTestProcess :: Process () -> Process ProcessId +startTestProcess proc = + spawnLocal $ do + getSelfPid >>= register "test-process" + runTestProcess proc + +-- | Control signals used to manage /test processes/ +data TestProcessControl = Stop | Go | Report ProcessId + deriving (Typeable, Generic) + +instance Binary TestProcessControl where + +-- | A mutable cell containing a test result. +type TestResult a = MVar a + +-- | Stashes a value in our 'TestResult' using @putMVar@ +stash :: TestResult a -> a -> Process () +stash mvar x = liftIO $ putMVar mvar x + +-- | Tell a /test process/ to stop (i.e., 'terminate') +testProcessStop :: ProcessId -> Process () +testProcessStop pid = send pid Stop + +-- | Tell a /test process/ to continue executing +testProcessGo :: ProcessId -> Process () +testProcessGo pid = send pid Go + +-- | A simple @Ping@ signal +data Ping = Ping + deriving (Typeable, Generic, Eq, Show) + +instance Binary Ping where +instance NFData Ping where + +ping :: ProcessId -> Process () +ping pid = send pid Ping + + +tryRunProcess :: LocalNode -> Process () -> IO () +tryRunProcess node p = do + tid <- liftIO myThreadId + runProcess node $ catch p (\e -> liftIO $ Exception.throwTo tid (e::SomeException)) + +-- | Tell a /test process/ to send a report (message) +-- back to the calling process +testProcessReport :: ProcessId -> Process () +testProcessReport pid = do + self <- getSelfPid + send pid $ Report self