distributed-process-supervisor (empty) → 0.1.1
raw patch · 7 files changed
+3719/−0 lines, 7 filesdep +HUnitdep +ansi-terminaldep +basesetup-changed
Dependencies added: HUnit, ansi-terminal, base, binary, bytestring, containers, data-accessor, deepseq, derive, distributed-process, distributed-process-client-server, distributed-process-extras, distributed-process-supervisor, distributed-static, fingertree, ghc-prim, hashable, mtl, network, network-transport, network-transport-tcp, rematch, stm, template-haskell, test-framework, test-framework-hunit, time, transformers, uniplate, unordered-containers
Files
- LICENCE +30/−0
- Setup.lhs +3/−0
- distributed-process-supervisor.cabal +97/−0
- src/Control/Distributed/Process/Supervisor.hs +1619/−0
- src/Control/Distributed/Process/Supervisor/Types.hs +370/−0
- tests/TestSupervisor.hs +1366/−0
- tests/TestUtils.hs +234/−0
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright Tim Watson, 2012-2013.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the author nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ distributed-process-supervisor.cabal view
@@ -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+
+ src/Control/Distributed/Process/Supervisor.hs view
@@ -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 <watson.timothy@gmail.com>+-- 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 })
+ src/Control/Distributed/Process/Supervisor/Types.hs view
@@ -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 <watson.timothy@gmail.com>+-- 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
+ tests/TestSupervisor.hs view
@@ -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+
+ tests/TestUtils.hs view
@@ -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