distributed-process-platform-0.1.0: src/Control/Distributed/Process/Platform/Supervisor.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverlappingInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Distributed.Process.Platform.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.Platform.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.Platform.Supervisor.Types
import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Serializable()
import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor)
import Control.Distributed.Process.Platform.Internal.Types
( ExitReason(..)
)
import Control.Distributed.Process.Platform.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.Platform.ManagedProcess.UnsafeClient as Unsafe
( call
, cast
)
import qualified Control.Distributed.Process.Platform.ManagedProcess as MP
( pserve
)
import Control.Distributed.Process.Platform.ManagedProcess.Server.Priority
( prioritiseCast_
, prioritiseCall_
, prioritiseInfo_
, setPriority
)
import Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted
( RestrictedProcess
, Result
, RestrictedAction
, getState
, putState
)
import qualified Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted as Restricted
( handleCallIf
, handleCall
, handleCast
, reply
, continue
)
-- import Control.Distributed.Process.Platform.ManagedProcess.Server.Unsafe
-- import Control.Distributed.Process.Platform.ManagedProcess.Server
import Control.Distributed.Process.Platform.Service.SystemLog
( LogClient
, LogChan
, LogText
, Logger(..)
)
import qualified Control.Distributed.Process.Platform.Service.SystemLog as Log
import Control.Distributed.Process.Platform.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.Platform.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.Platform.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 })