{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE PatternGuards             #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}

-----------------------------------------------------------------------------
-- |
-- 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 client functions in this module will cause the
-- calling process to exit unless the specified supervisor process can be resolved.
--
-- [Supervision Principles]
--
-- A supervisor is responsible for starting, stopping and monitoring its child
-- processes so as to keep them alive by restarting them when necessary.
--
-- The supervisor's children are defined as a list of child specifications
-- (see "ChildSpec"). When a supervisor is started, its children are started
-- in left-to-right (insertion order) according to this list. When a supervisor
-- stops (or exits for any reason), it will stop all its children before exiting.
-- Child specs can be added to the supervisor after it has started, either on
-- the left or right of the existing list of child specs.
--
-- [Restart Strategies]
--
-- 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 stop 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,
-- stopping all its children (in left-to-right order) and exit with the
-- reason @ExitOther "ReachedMaxRestartIntensity"@.
--
-- The 'MaxRestarts' type is a positive integer, and together with a specified
-- @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 Stop Policies]
--
-- When the supervisor detects that a child has died, the 'RestartPolicy'
-- configured in the child specification is used to determin what to do. If
-- the this is set to @Permanent@, then the child is always restarted.
-- If it is @Temporary@, then the child is never restarted and the child
-- specification is removed from the supervisor. A @Transient@ child will
-- be restarted only if it exits /abnormally/, otherwise it is left
-- inactive (but its specification is left in place). Finally, an @Intrinsic@
-- child is treated like a @Transient@ one, except that if /this/ kind of child
-- exits /normally/, then the supervisor will also exit normally.
--
-- When the supervisor does stop a child process, the "ChildStopPolicy"
-- provided with the 'ChildSpec' determines how the supervisor should go
-- about doing so. If this is "StopImmediately", then the child will
-- be killed without further notice, which means the child will /not/ have
-- an opportunity to clean up any internal state and/or release any held
-- resources. If the policy is @StopTimeout delay@ however, the child
-- will be sent an /exit signal/ instead, i.e., the supervisor will cause
-- the child to exit via @exit childPid ExitShutdown@, and then will wait
-- until the given @delay@ for the child to exit normally. If this does not
-- happen within the given delay, the supervisor will revert to the more
-- aggressive "StopImmediately" policy and try again. Any errors that
-- occur during a timed-out shutdown will be logged, however exit reasons
-- resulting from "StopImmediately" are ignored.
--
-- [Creating Child Specs]
--
-- The 'ToChildStart' typeclass simplifies the process of defining a 'ChildStart'
-- providing two default instances from which a 'ChildStart' datum can be
-- generated. The first, takes a @Closure (Process ())@, where the enclosed
-- action (in the @Process@ monad) is the actual (long running) code that we
-- wish to supervise. In the case of a /managed process/, this is usually the
-- server loop, constructed by evaluating some variant of @ManagedProcess.serve@.
--
-- The second instance supports returning a /handle/ which can contain extra
-- data about the child process - usually this is a newtype wrapper used by
-- clients to communicate with the process.
--
-- When the supervisor spawns its child processes, they should be linked to their
-- parent (i.e., the supervisor), such that even if the supervisor is killed
-- abruptly by an asynchronous exception, the children will still be taken down
-- with it, though somewhat less ceremoniously in that case. This behaviour is
-- injected by the supervisor for any "ChildStart" built on @Closure (Process ())@
-- automatically, but the /handle/ based approach requires that the @Closure@
-- responsible for spawning does the linking itself.
--
-- Finally, we provide a simple shortcut to @staticClosure@, for consumers
-- who've manually registered with the /remote table/ and don't with to use
-- tempate haskell (e.g. users of the Explicit closures API).
--
-- [Supervision Trees & Supervisor Shutdown]
--
-- To create a supervision tree, one simply adds supervisors below one another
-- as children, setting the @childType@ field of their 'ChildSpec' to
-- @Supervisor@ instead of @Worker@. Supervision tree can be arbitrarilly
-- 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(..)
  , ChildStopPolicy(..)
  , ChildStart(..)
  , RegisteredName(LocalName, CustomRegister)
  , RestartPolicy(..)
--  , ChildRestart(..)
  , ChildRef(..)
  , isRunning
  , isRestarting
  , Child
  , StaticLabel
  , SupervisorPid
  , ChildPid
  , 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
  , stopChild
  , StopChildResult(..)
  , deleteChild
  , DeleteChildResult(..)
  , restartChild
  , RestartChildResult(..)
    -- * Normative Shutdown
  , shutdown
  , shutdownAndWait
    -- * Queries and Statistics
  , lookupChild
  , listChildren
  , SupervisorStats(..)
  , statistics
  , getRestartIntensity
  , definedChildren
  , definedWorkers
  , definedSupervisors
  , runningChildren
  , runningWorkers
  , runningSupervisors
    -- * Additional (Misc) Types
  , StartFailure(..)
  , ChildInitFailure(..)
  ) where

import Control.DeepSeq (NFData)

import Control.Distributed.Process.Supervisor.Types
import Control.Distributed.Process
  ( Process
  , ProcessId
  , MonitorRef
  , DiedReason(..)
  , Match
  , Handler(..)
  , Message
  , ProcessMonitorNotification(..)
  , Closure
  , Static
  , exit
  , kill
  , match
  , matchIf
  , monitor
  , getSelfPid
  , liftIO
  , catchExit
  , catchesExit
  , catches
  , die
  , link
  , send
  , register
  , spawnLocal
  , unsafeWrapMessage
  , unmonitor
  , withMonitor_
  , expect
  , unClosure
  , receiveWait
  , receiveTimeout
  , handleMessageIf
  )
import Control.Distributed.Process.Management (mxNotify, MxEvent(MxUser))
import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor)
import Control.Distributed.Process.Extras.Internal.Types
  ( ExitReason(..)
  )
import Control.Distributed.Process.ManagedProcess
  ( handleCall
  , handleInfo
  , reply
  , continue
  , stop
  , stopWith
  , input
  , defaultProcess
  , prioritised
  , InitHandler
  , InitResult(..)
  , ProcessAction
  , ProcessReply
  , ProcessDefinition(..)
  , PrioritisedProcessDefinition(..)
  , Priority()
  , DispatchPriority
  , UnhandledMessagePolicy(Drop)
  , ExitState
  , exitState
  )
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
  , evalAfter
  )
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.Distributed.Static
  ( staticClosure
  )
import Control.Exception (SomeException, throwIO)
import Control.Monad.Catch (catch, finally, mask)
import Control.Monad (void, forM)

import Data.Accessor
  ( Accessor
  , accessor
  , (^:)
  , (.>)
  , (^=)
  , (^.)
  )
import Data.Binary (Binary)
import Data.Foldable (find, foldlM, toList)
import Data.List (foldl')
import qualified Data.List as List (lookup)
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)

import Prelude hiding (filter, init, rem)

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 :: Closure (Process ()) -> Process ChildStart
toChildStart = ChildStart -> Process ChildStart
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildStart -> Process ChildStart)
-> (Closure (Process ()) -> ChildStart)
-> Closure (Process ())
-> Process ChildStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Process ()) -> ChildStart
RunClosure

instance ToChildStart (Closure (SupervisorPid -> Process (ChildPid, Message))) where
  toChildStart :: Closure (SupervisorPid -> Process (SupervisorPid, Message))
-> Process ChildStart
toChildStart = ChildStart -> Process ChildStart
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildStart -> Process ChildStart)
-> (Closure (SupervisorPid -> Process (SupervisorPid, Message))
    -> ChildStart)
-> Closure (SupervisorPid -> Process (SupervisorPid, Message))
-> Process ChildStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (SupervisorPid -> Process (SupervisorPid, Message))
-> ChildStart
CreateHandle

instance ToChildStart (Static (Process ())) where
  toChildStart :: Static (Process ()) -> Process ChildStart
toChildStart = Closure (Process ()) -> Process ChildStart
forall a. ToChildStart a => a -> Process ChildStart
toChildStart (Closure (Process ()) -> Process ChildStart)
-> (Static (Process ()) -> Closure (Process ()))
-> Static (Process ())
-> Process ChildStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Static (Process ()) -> Closure (Process ())
forall a. Static a -> Closure a
staticClosure

-- internal APIs. The corresponding XxxResult types are in
-- Control.Distributed.Process.Supervisor.Types

data DeleteChild = DeleteChild !ChildKey
  deriving (Typeable, (forall x. DeleteChild -> Rep DeleteChild x)
-> (forall x. Rep DeleteChild x -> DeleteChild)
-> Generic DeleteChild
forall x. Rep DeleteChild x -> DeleteChild
forall x. DeleteChild -> Rep DeleteChild x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DeleteChild -> Rep DeleteChild x
from :: forall x. DeleteChild -> Rep DeleteChild x
$cto :: forall x. Rep DeleteChild x -> DeleteChild
to :: forall x. Rep DeleteChild x -> DeleteChild
Generic)
instance Binary DeleteChild where
instance NFData DeleteChild where

data FindReq = FindReq ChildKey
    deriving (Typeable, (forall x. FindReq -> Rep FindReq x)
-> (forall x. Rep FindReq x -> FindReq) -> Generic FindReq
forall x. Rep FindReq x -> FindReq
forall x. FindReq -> Rep FindReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FindReq -> Rep FindReq x
from :: forall x. FindReq -> Rep FindReq x
$cto :: forall x. Rep FindReq x -> FindReq
to :: forall x. Rep FindReq x -> FindReq
Generic)
instance Binary FindReq where
instance NFData FindReq where

data StatsReq = StatsReq
    deriving (Typeable, (forall x. StatsReq -> Rep StatsReq x)
-> (forall x. Rep StatsReq x -> StatsReq) -> Generic StatsReq
forall x. Rep StatsReq x -> StatsReq
forall x. StatsReq -> Rep StatsReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StatsReq -> Rep StatsReq x
from :: forall x. StatsReq -> Rep StatsReq x
$cto :: forall x. Rep StatsReq x -> StatsReq
to :: forall x. Rep StatsReq x -> StatsReq
Generic)
instance Binary StatsReq where
instance NFData StatsReq where

data ListReq = ListReq
    deriving (Typeable, (forall x. ListReq -> Rep ListReq x)
-> (forall x. Rep ListReq x -> ListReq) -> Generic ListReq
forall x. Rep ListReq x -> ListReq
forall x. ListReq -> Rep ListReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ListReq -> Rep ListReq x
from :: forall x. ListReq -> Rep ListReq x
$cto :: forall x. Rep ListReq x -> ListReq
to :: forall x. Rep ListReq x -> ListReq
Generic)
instance Binary ListReq where
instance NFData ListReq where

type ImmediateStart = Bool

data AddChildReq = AddChild !ImmediateStart !ChildSpec
    deriving (Typeable, (forall x. AddChildReq -> Rep AddChildReq x)
-> (forall x. Rep AddChildReq x -> AddChildReq)
-> Generic AddChildReq
forall x. Rep AddChildReq x -> AddChildReq
forall x. AddChildReq -> Rep AddChildReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AddChildReq -> Rep AddChildReq x
from :: forall x. AddChildReq -> Rep AddChildReq x
$cto :: forall x. Rep AddChildReq x -> AddChildReq
to :: forall x. Rep AddChildReq x -> AddChildReq
Generic, Int -> AddChildReq -> ShowS
[AddChildReq] -> ShowS
AddChildReq -> ChildKey
(Int -> AddChildReq -> ShowS)
-> (AddChildReq -> ChildKey)
-> ([AddChildReq] -> ShowS)
-> Show AddChildReq
forall a.
(Int -> a -> ShowS) -> (a -> ChildKey) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddChildReq -> ShowS
showsPrec :: Int -> AddChildReq -> ShowS
$cshow :: AddChildReq -> ChildKey
show :: AddChildReq -> ChildKey
$cshowList :: [AddChildReq] -> ShowS
showList :: [AddChildReq] -> ShowS
Show)
instance Binary AddChildReq where
instance NFData AddChildReq where

data AddChildRes = Exists ChildRef | Added State

data StartChildReq = StartChild !ChildKey
  deriving (Typeable, (forall x. StartChildReq -> Rep StartChildReq x)
-> (forall x. Rep StartChildReq x -> StartChildReq)
-> Generic StartChildReq
forall x. Rep StartChildReq x -> StartChildReq
forall x. StartChildReq -> Rep StartChildReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StartChildReq -> Rep StartChildReq x
from :: forall x. StartChildReq -> Rep StartChildReq x
$cto :: forall x. Rep StartChildReq x -> StartChildReq
to :: forall x. Rep StartChildReq x -> StartChildReq
Generic)
instance Binary StartChildReq where
instance NFData StartChildReq where

data RestartChildReq = RestartChildReq !ChildKey
  deriving (Typeable, (forall x. RestartChildReq -> Rep RestartChildReq x)
-> (forall x. Rep RestartChildReq x -> RestartChildReq)
-> Generic RestartChildReq
forall x. Rep RestartChildReq x -> RestartChildReq
forall x. RestartChildReq -> Rep RestartChildReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RestartChildReq -> Rep RestartChildReq x
from :: forall x. RestartChildReq -> Rep RestartChildReq x
$cto :: forall x. Rep RestartChildReq x -> RestartChildReq
to :: forall x. Rep RestartChildReq x -> RestartChildReq
Generic, Int -> RestartChildReq -> ShowS
[RestartChildReq] -> ShowS
RestartChildReq -> ChildKey
(Int -> RestartChildReq -> ShowS)
-> (RestartChildReq -> ChildKey)
-> ([RestartChildReq] -> ShowS)
-> Show RestartChildReq
forall a.
(Int -> a -> ShowS) -> (a -> ChildKey) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RestartChildReq -> ShowS
showsPrec :: Int -> RestartChildReq -> ShowS
$cshow :: RestartChildReq -> ChildKey
show :: RestartChildReq -> ChildKey
$cshowList :: [RestartChildReq] -> ShowS
showList :: [RestartChildReq] -> ShowS
Show, RestartChildReq -> RestartChildReq -> ImmediateStart
(RestartChildReq -> RestartChildReq -> ImmediateStart)
-> (RestartChildReq -> RestartChildReq -> ImmediateStart)
-> Eq RestartChildReq
forall a.
(a -> a -> ImmediateStart) -> (a -> a -> ImmediateStart) -> Eq a
$c== :: RestartChildReq -> RestartChildReq -> ImmediateStart
== :: RestartChildReq -> RestartChildReq -> ImmediateStart
$c/= :: RestartChildReq -> RestartChildReq -> ImmediateStart
/= :: RestartChildReq -> RestartChildReq -> ImmediateStart
Eq)
instance Binary RestartChildReq where
instance NFData RestartChildReq where

data DelayedRestart = DelayedRestart !ChildKey !DiedReason
  deriving (Typeable, (forall x. DelayedRestart -> Rep DelayedRestart x)
-> (forall x. Rep DelayedRestart x -> DelayedRestart)
-> Generic DelayedRestart
forall x. Rep DelayedRestart x -> DelayedRestart
forall x. DelayedRestart -> Rep DelayedRestart x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DelayedRestart -> Rep DelayedRestart x
from :: forall x. DelayedRestart -> Rep DelayedRestart x
$cto :: forall x. Rep DelayedRestart x -> DelayedRestart
to :: forall x. Rep DelayedRestart x -> DelayedRestart
Generic, Int -> DelayedRestart -> ShowS
[DelayedRestart] -> ShowS
DelayedRestart -> ChildKey
(Int -> DelayedRestart -> ShowS)
-> (DelayedRestart -> ChildKey)
-> ([DelayedRestart] -> ShowS)
-> Show DelayedRestart
forall a.
(Int -> a -> ShowS) -> (a -> ChildKey) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DelayedRestart -> ShowS
showsPrec :: Int -> DelayedRestart -> ShowS
$cshow :: DelayedRestart -> ChildKey
show :: DelayedRestart -> ChildKey
$cshowList :: [DelayedRestart] -> ShowS
showList :: [DelayedRestart] -> ShowS
Show, DelayedRestart -> DelayedRestart -> ImmediateStart
(DelayedRestart -> DelayedRestart -> ImmediateStart)
-> (DelayedRestart -> DelayedRestart -> ImmediateStart)
-> Eq DelayedRestart
forall a.
(a -> a -> ImmediateStart) -> (a -> a -> ImmediateStart) -> Eq a
$c== :: DelayedRestart -> DelayedRestart -> ImmediateStart
== :: DelayedRestart -> DelayedRestart -> ImmediateStart
$c/= :: DelayedRestart -> DelayedRestart -> ImmediateStart
/= :: DelayedRestart -> DelayedRestart -> ImmediateStart
Eq)
instance Binary DelayedRestart where
instance NFData DelayedRestart

data StopChildReq = StopChildReq !ChildKey
  deriving (Typeable, (forall x. StopChildReq -> Rep StopChildReq x)
-> (forall x. Rep StopChildReq x -> StopChildReq)
-> Generic StopChildReq
forall x. Rep StopChildReq x -> StopChildReq
forall x. StopChildReq -> Rep StopChildReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StopChildReq -> Rep StopChildReq x
from :: forall x. StopChildReq -> Rep StopChildReq x
$cto :: forall x. Rep StopChildReq x -> StopChildReq
to :: forall x. Rep StopChildReq x -> StopChildReq
Generic, Int -> StopChildReq -> ShowS
[StopChildReq] -> ShowS
StopChildReq -> ChildKey
(Int -> StopChildReq -> ShowS)
-> (StopChildReq -> ChildKey)
-> ([StopChildReq] -> ShowS)
-> Show StopChildReq
forall a.
(Int -> a -> ShowS) -> (a -> ChildKey) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StopChildReq -> ShowS
showsPrec :: Int -> StopChildReq -> ShowS
$cshow :: StopChildReq -> ChildKey
show :: StopChildReq -> ChildKey
$cshowList :: [StopChildReq] -> ShowS
showList :: [StopChildReq] -> ShowS
Show, StopChildReq -> StopChildReq -> ImmediateStart
(StopChildReq -> StopChildReq -> ImmediateStart)
-> (StopChildReq -> StopChildReq -> ImmediateStart)
-> Eq StopChildReq
forall a.
(a -> a -> ImmediateStart) -> (a -> a -> ImmediateStart) -> Eq a
$c== :: StopChildReq -> StopChildReq -> ImmediateStart
== :: StopChildReq -> StopChildReq -> ImmediateStart
$c/= :: StopChildReq -> StopChildReq -> ImmediateStart
/= :: StopChildReq -> StopChildReq -> ImmediateStart
Eq)
instance Binary StopChildReq where
instance NFData StopChildReq where

data IgnoreChildReq = IgnoreChildReq !ChildPid
  deriving (Typeable, (forall x. IgnoreChildReq -> Rep IgnoreChildReq x)
-> (forall x. Rep IgnoreChildReq x -> IgnoreChildReq)
-> Generic IgnoreChildReq
forall x. Rep IgnoreChildReq x -> IgnoreChildReq
forall x. IgnoreChildReq -> Rep IgnoreChildReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IgnoreChildReq -> Rep IgnoreChildReq x
from :: forall x. IgnoreChildReq -> Rep IgnoreChildReq x
$cto :: forall x. Rep IgnoreChildReq x -> IgnoreChildReq
to :: forall x. Rep IgnoreChildReq x -> IgnoreChildReq
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 :: LogSink -> LogMessage -> Process ()
logMessage LogSink
LogChan              = LogChan -> LogMessage -> Process ()
forall a. Logger a => a -> LogMessage -> Process ()
logMessage LogChan
Log.logChannel
  logMessage (LogProcess LogClient
client') = LogClient -> LogMessage -> Process ()
forall a. Logger a => a -> LogMessage -> Process ()
logMessage LogClient
client'

data State = State {
    State -> ChildSpecs
_specs           :: ChildSpecs
  , State -> Map SupervisorPid ChildKey
_active          :: Map ChildPid ChildKey
  , State -> RestartStrategy
_strategy        :: RestartStrategy
  , State -> NominalDiffTime
_restartPeriod   :: NominalDiffTime
  , State -> [UTCTime]
_restarts        :: [UTCTime]
  , State -> SupervisorStats
_stats           :: SupervisorStats
  , State -> LogSink
_logger          :: LogSink
  , State -> ShutdownMode
shutdownStrategy :: ShutdownMode
  }

supErrId :: String -> String
supErrId :: ShowS
supErrId ChildKey
s = ChildKey
"Control.Distributed.Process" ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
s

--------------------------------------------------------------------------------
-- Starting/Running Supervisor                                                --
--------------------------------------------------------------------------------

-- | Start a supervisor (process), running the supplied children and restart
-- strategy.
--
-- > start = spawnLocal . run
--
start :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process SupervisorPid
start :: RestartStrategy
-> ShutdownMode -> [ChildSpec] -> Process SupervisorPid
start RestartStrategy
rs ShutdownMode
ss [ChildSpec]
cs = Process () -> Process SupervisorPid
spawnLocal (Process () -> Process SupervisorPid)
-> Process () -> Process SupervisorPid
forall a b. (a -> b) -> a -> b
$ RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ()
run RestartStrategy
rs ShutdownMode
ss [ChildSpec]
cs

-- | Run the supplied children using the provided restart strategy.
--
run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ()
run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ()
run RestartStrategy
rs ShutdownMode
ss [ChildSpec]
specs' = (RestartStrategy, ShutdownMode, [ChildSpec])
-> InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State
-> PrioritisedProcessDefinition State
-> Process ()
forall a s.
a
-> InitHandler a s -> PrioritisedProcessDefinition s -> Process ()
MP.pserve (RestartStrategy
rs, ShutdownMode
ss, [ChildSpec]
specs') InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State
supInit PrioritisedProcessDefinition State
serverDefinition

--------------------------------------------------------------------------------
-- Client Facing API                                                          --
--------------------------------------------------------------------------------

-- | Obtain statistics about a running supervisor.
--
statistics :: Addressable a => a -> Process (SupervisorStats)
statistics :: forall a. Addressable a => a -> Process SupervisorStats
statistics = ((a -> StatsReq -> Process SupervisorStats)
-> StatsReq -> a -> Process SupervisorStats
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> StatsReq -> Process SupervisorStats
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call) StatsReq
StatsReq

-- | Lookup a possibly supervised child, given its 'ChildKey'.
--
lookupChild :: Addressable a => a -> ChildKey -> Process (Maybe (ChildRef, ChildSpec))
lookupChild :: forall a. Addressable a => a -> ChildKey -> Process (Maybe Child)
lookupChild a
addr ChildKey
key = a -> FindReq -> Process (Maybe Child)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
addr (FindReq -> Process (Maybe Child))
-> FindReq -> Process (Maybe Child)
forall a b. (a -> b) -> a -> b
$ ChildKey -> FindReq
FindReq ChildKey
key

-- | List all know (i.e., configured) children.
--
listChildren :: Addressable a => a -> Process [Child]
listChildren :: forall a. Addressable a => a -> Process [Child]
listChildren a
addr = a -> ListReq -> Process [Child]
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
addr ListReq
ListReq

-- | Add a new child.
--
addChild :: Addressable a => a -> ChildSpec -> Process AddChildResult
addChild :: forall a. Addressable a => a -> ChildSpec -> Process AddChildResult
addChild a
addr ChildSpec
spec = a -> AddChildReq -> Process AddChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
addr (AddChildReq -> Process AddChildResult)
-> AddChildReq -> Process AddChildResult
forall a b. (a -> b) -> a -> b
$ ImmediateStart -> ChildSpec -> AddChildReq
AddChild ImmediateStart
False ChildSpec
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 :: forall a.
Addressable a =>
a -> ChildKey -> Process StartChildResult
startChild a
addr ChildKey
key = a -> StartChildReq -> Process StartChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
addr (StartChildReq -> Process StartChildResult)
-> StartChildReq -> Process StartChildResult
forall a b. (a -> b) -> a -> b
$ ChildKey -> StartChildReq
StartChild ChildKey
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 :: forall a. Addressable a => a -> ChildSpec -> Process AddChildResult
startNewChild a
addr ChildSpec
spec = a -> AddChildReq -> Process AddChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
addr (AddChildReq -> Process AddChildResult)
-> AddChildReq -> Process AddChildResult
forall a b. (a -> b) -> a -> b
$ ImmediateStart -> ChildSpec -> AddChildReq
AddChild ImmediateStart
True ChildSpec
spec

-- | Delete a supervised child. The child must already be stopped (see
-- 'stopChild').
--
deleteChild :: Addressable a => a -> ChildKey -> Process DeleteChildResult
deleteChild :: forall a.
Addressable a =>
a -> ChildKey -> Process DeleteChildResult
deleteChild a
sid ChildKey
childKey = a -> DeleteChild -> Process DeleteChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
sid (DeleteChild -> Process DeleteChildResult)
-> DeleteChild -> Process DeleteChildResult
forall a b. (a -> b) -> a -> b
$ ChildKey -> DeleteChild
DeleteChild ChildKey
childKey

-- | Stop a running child.
--
stopChild :: Addressable a
               => a
               -> ChildKey
               -> Process StopChildResult
stopChild :: forall a. Addressable a => a -> ChildKey -> Process StopChildResult
stopChild a
sid = a -> StopChildReq -> Process StopChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
sid (StopChildReq -> Process StopChildResult)
-> (ChildKey -> StopChildReq)
-> ChildKey
-> Process StopChildResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildKey -> StopChildReq
StopChildReq

-- | Forcibly restart a running child.
--
restartChild :: Addressable a
             => a
             -> ChildKey
             -> Process RestartChildResult
restartChild :: forall a.
Addressable a =>
a -> ChildKey -> Process RestartChildResult
restartChild a
sid = a -> RestartChildReq -> Process RestartChildResult
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
Unsafe.call a
sid (RestartChildReq -> Process RestartChildResult)
-> (ChildKey -> RestartChildReq)
-> ChildKey
-> Process RestartChildResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildKey -> RestartChildReq
RestartChildReq

-- | Gracefully stop/shutdown a running supervisor. Returns immediately if the
-- /address/ cannot be resolved.
--
shutdown :: Resolvable a => a -> Process ()
shutdown :: forall a. Resolvable a => a -> Process ()
shutdown a
sid = do
  Maybe SupervisorPid
mPid <- a -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve a
sid
  case Maybe SupervisorPid
mPid of
    Maybe SupervisorPid
Nothing -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just SupervisorPid
p  -> SupervisorPid -> ExitReason -> Process ()
forall a. Serializable a => SupervisorPid -> a -> Process ()
exit SupervisorPid
p ExitReason
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 :: forall a. Resolvable a => a -> Process ()
shutdownAndWait a
sid = do
  Maybe SupervisorPid
mPid <- a -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve a
sid
  case Maybe SupervisorPid
mPid of
    Maybe SupervisorPid
Nothing -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just SupervisorPid
p  -> SupervisorPid -> Process () -> Process ()
forall a. SupervisorPid -> Process a -> Process a
withMonitor_ SupervisorPid
p (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
      SupervisorPid -> Process ()
forall a. Resolvable a => a -> Process ()
shutdown SupervisorPid
p
      [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [ (ProcessMonitorNotification -> ImmediateStart)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> ImmediateStart) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
_ SupervisorPid
p' DiedReason
_) -> SupervisorPid
p' SupervisorPid -> SupervisorPid -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== SupervisorPid
p)
                            (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                  ]

--------------------------------------------------------------------------------
-- Server Initialisation/Startup                                              --
--------------------------------------------------------------------------------

supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State
supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State
supInit (RestartStrategy
strategy', ShutdownMode
shutdown', [ChildSpec]
specs') = do
  Maybe LogClient
logClient <- Process (Maybe LogClient)
Log.client
  let client' :: LogSink
client' = case Maybe LogClient
logClient of
                  Maybe LogClient
Nothing -> LogSink
LogChan
                  Just LogClient
c  -> LogClient -> LogSink
LogProcess LogClient
c
  let initState :: State
initState = ( ( -- as a NominalDiffTime (in seconds)
                      Accessor State NominalDiffTime
restartPeriod Accessor State NominalDiffTime -> NominalDiffTime -> State -> State
forall r a. T r a -> a -> r -> r
^= NominalDiffTime
configuredRestartPeriod
                    )
                  (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accessor State RestartStrategy
strategy Accessor State RestartStrategy -> RestartStrategy -> State -> State
forall r a. T r a -> a -> r -> r
^= RestartStrategy
strategy')
                  (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accessor State LogSink
logger   Accessor State LogSink -> LogSink -> State -> State
forall r a. T r a -> a -> r -> r
^= LogSink
client')
                  (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ ShutdownMode -> State
emptyState ShutdownMode
shutdown'
                  )
  -- TODO: should we return Ignore, as per OTP's supervisor, if no child starts?
  Process (InitResult State)
-> (SomeException -> Process (InitResult State))
-> Process (InitResult State)
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch ((State -> ChildSpec -> Process State)
-> State -> [ChildSpec] -> Process State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM State -> ChildSpec -> Process State
initChild State
initState [ChildSpec]
specs' Process State
-> (State -> Process (InitResult State))
-> Process (InitResult State)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InitResult State -> Process (InitResult State)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (InitResult State -> Process (InitResult State))
-> (State -> InitResult State)
-> State
-> Process (InitResult State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((State -> Delay -> InitResult State)
-> Delay -> State -> InitResult State
forall a b c. (a -> b -> c) -> b -> a -> c
flip State -> Delay -> InitResult State
forall s. s -> Delay -> InitResult s
InitOk) Delay
Infinity)
        (\(SomeException
e :: SomeException) -> do
          SupervisorPid
sup <- Process SupervisorPid
getSelfPid
          (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.error (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$
            ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"Could not init supervisor " SupervisorPid
sup ChildKey
"noproc" (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
e)
          InitResult State -> Process (InitResult State)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (InitResult State -> Process (InitResult State))
-> InitResult State -> Process (InitResult State)
forall a b. (a -> b) -> a -> b
$ ChildKey -> InitResult State
forall s. ChildKey -> InitResult s
InitStop (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
e))
  where
    initChild :: State -> ChildSpec -> Process State
    initChild :: State -> ChildSpec -> Process State
initChild State
st ChildSpec
ch =
      case (ChildKey -> State -> Maybe Child
findChild (ChildSpec -> ChildKey
childKey ChildSpec
ch) State
st) of
        Just (ChildRef
ref, ChildSpec
_) -> StartFailure -> Process State
forall a b. Serializable a => a -> Process b
die (StartFailure -> Process State) -> StartFailure -> Process State
forall a b. (a -> b) -> a -> b
$ ChildRef -> StartFailure
StartFailureDuplicateChild ChildRef
ref
        Maybe Child
Nothing       -> ChildSpec -> Process (Either StartFailure ChildRef)
tryStartChild ChildSpec
ch Process (Either StartFailure ChildRef)
-> (Either StartFailure ChildRef -> Process State) -> Process State
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= State -> ChildSpec -> Either StartFailure ChildRef -> Process State
initialised State
st ChildSpec
ch

    configuredRestartPeriod :: NominalDiffTime
configuredRestartPeriod =
      let maxT' :: TimeInterval
maxT' = RestartLimit -> TimeInterval
maxT (RestartStrategy -> RestartLimit
intensity RestartStrategy
strategy')
          tI :: Int
tI    = TimeInterval -> Int
asTimeout TimeInterval
maxT'
          tMs :: Float
tMs   = (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tI Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
0.000001 :: Float))
      in Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Float -> Rational
forall a. Real a => a -> Rational
toRational Float
tMs) :: NominalDiffTime

initialised :: State
            -> ChildSpec
            -> Either StartFailure ChildRef
            -> Process State
initialised :: State -> ChildSpec -> Either StartFailure ChildRef -> Process State
initialised State
_     ChildSpec
_    (Left  StartFailure
err) = IO State -> Process State
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO State -> Process State) -> IO State -> Process State
forall a b. (a -> b) -> a -> b
$ ChildInitFailure -> IO State
forall e a. Exception e => e -> IO a
throwIO (ChildInitFailure -> IO State) -> ChildInitFailure -> IO State
forall a b. (a -> b) -> a -> b
$ ChildKey -> ChildInitFailure
ChildInitFailure (StartFailure -> ChildKey
forall a. Show a => a -> ChildKey
show StartFailure
err)
initialised State
state ChildSpec
spec (Right ChildRef
ref) = do
  Maybe SupervisorPid
mPid <- ChildRef -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve ChildRef
ref
  case Maybe SupervisorPid
mPid of
    Maybe SupervisorPid
Nothing  -> ChildKey -> Process State
forall a b. Serializable a => a -> Process b
die (ChildKey -> Process State) -> ChildKey -> Process State
forall a b. (a -> b) -> a -> b
$ (ShowS
supErrId ChildKey
".initChild:child=") ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ (ChildSpec -> ChildKey
childKey ChildSpec
spec) ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
":InvalidChildRef"
    Just SupervisorPid
childPid -> do
      State -> Process State
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Process State) -> State -> Process State
forall a b. (a -> b) -> a -> b
$ ( (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey)
-> State
-> State
forall r a. T r a -> (a -> a) -> r -> r
^: SupervisorPid
-> ChildKey
-> Map SupervisorPid ChildKey
-> Map SupervisorPid ChildKey
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SupervisorPid
childPid ChildKey
chId)
               (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accessor State ChildSpecs
specs  Accessor State ChildSpecs
-> (ChildSpecs -> ChildSpecs) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: (ChildSpecs -> Child -> ChildSpecs
forall a. Seq a -> a -> Seq a
|> (ChildRef
ref, ChildSpec
spec)))
               (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Active ChildType
chType (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) State
state
               )
  where chId :: ChildKey
chId   = ChildSpec -> ChildKey
childKey ChildSpec
spec
        chType :: ChildType
chType = ChildSpec -> ChildType
childType ChildSpec
spec

--------------------------------------------------------------------------------
-- Server Definition/State                                                    --
--------------------------------------------------------------------------------

emptyState :: ShutdownMode -> State
emptyState :: ShutdownMode -> State
emptyState ShutdownMode
strat = State {
    _specs :: ChildSpecs
_specs           = ChildSpecs
forall a. Seq a
Seq.empty
  , _active :: Map SupervisorPid ChildKey
_active          = Map SupervisorPid ChildKey
forall k a. Map k a
Map.empty
  , _strategy :: RestartStrategy
_strategy        = RestartStrategy
restartAll
  , _restartPeriod :: NominalDiffTime
_restartPeriod   = (Integer -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
0 :: Integer)) :: NominalDiffTime
  , _restarts :: [UTCTime]
_restarts        = []
  , _stats :: SupervisorStats
_stats           = SupervisorStats
emptyStats
  , _logger :: LogSink
_logger          = LogSink
LogChan
  , shutdownStrategy :: ShutdownMode
shutdownStrategy = ShutdownMode
strat
  }

emptyStats :: SupervisorStats
emptyStats :: SupervisorStats
emptyStats = SupervisorStats {
    _children :: Int
_children          = Int
0
  , _workers :: Int
_workers           = Int
0
  , _supervisors :: Int
_supervisors       = Int
0
  , _running :: Int
_running           = Int
0
  , _activeSupervisors :: Int
_activeSupervisors = Int
0
  , _activeWorkers :: Int
_activeWorkers     = Int
0
  , totalRestarts :: Int
totalRestarts      = Int
0
--  , avgRestartFrequency   = 0
  }

serverDefinition :: PrioritisedProcessDefinition State
serverDefinition :: PrioritisedProcessDefinition State
serverDefinition = ProcessDefinition State
-> [DispatchPriority State] -> PrioritisedProcessDefinition State
forall s.
ProcessDefinition s
-> [DispatchPriority s] -> PrioritisedProcessDefinition s
prioritised ProcessDefinition State
processDefinition [DispatchPriority State]
supPriorities
  where
    supPriorities :: [DispatchPriority State]
    supPriorities :: [DispatchPriority State]
supPriorities = [
        (IgnoreChildReq -> Priority ()) -> DispatchPriority State
forall s a.
Serializable a =>
(a -> Priority ()) -> DispatchPriority s
prioritiseCast_ (\(IgnoreChildReq SupervisorPid
_)                 -> Int -> Priority ()
forall m. Int -> Priority m
setPriority Int
100)
      , (ProcessMonitorNotification -> Priority ())
-> DispatchPriority State
forall s a.
Serializable a =>
(a -> Priority ()) -> DispatchPriority s
prioritiseInfo_ (\(ProcessMonitorNotification MonitorRef
_ SupervisorPid
_ DiedReason
_) -> Int -> Priority ()
forall m. Int -> Priority m
setPriority Int
99 )
      , (DelayedRestart -> Priority ()) -> DispatchPriority State
forall s a.
Serializable a =>
(a -> Priority ()) -> DispatchPriority s
prioritiseInfo_ (\(DelayedRestart ChildKey
_ DiedReason
_)               -> Int -> Priority ()
forall m. Int -> Priority m
setPriority Int
80 )
      , (FindReq -> Priority (Maybe Child)) -> DispatchPriority State
forall s a b.
(Serializable a, Serializable b) =>
(a -> Priority b) -> DispatchPriority s
prioritiseCall_ (\(FindReq
_ :: FindReq) ->
                          (Int -> Priority (Maybe Child)
forall m. Int -> Priority m
setPriority Int
10) :: Priority (Maybe (ChildRef, ChildSpec)))
      ]

processDefinition :: ProcessDefinition State
processDefinition :: ProcessDefinition State
processDefinition =
  ProcessDefinition State
forall s. ProcessDefinition s
defaultProcess {
    apiHandlers = [
       Restricted.handleCast   handleIgnore
       -- adding, removing and (optionally) starting new child specs
     , handleCall              handleStopChild
     , Restricted.handleCall   handleDeleteChild
     , Restricted.handleCallIf (input (\(AddChild ImmediateStart
immediate ChildSpec
_) -> ImmediateStart -> ImmediateStart
not ImmediateStart
immediate))
                               handleAddChild
     , handleCall              handleStartNewChild
     , handleCall              handleStartChild
     , handleCall              handleRestartChild
       -- stats/info
     , Restricted.handleCall   handleLookupChild
     , Restricted.handleCall   handleListChildren
     , Restricted.handleCall   handleGetStats
     ]
  , infoHandlers = [ handleInfo handleMonitorSignal
                   , handleInfo handleDelayedRestart
                   ]
  , shutdownHandler = handleShutdown
  , unhandledMessagePolicy = Drop
  } :: ProcessDefinition State

--------------------------------------------------------------------------------
-- API Handlers                                                               --
--------------------------------------------------------------------------------

handleLookupChild :: FindReq
                  -> RestrictedProcess State (Result (Maybe (ChildRef, ChildSpec)))
handleLookupChild :: FindReq -> RestrictedProcess State (Result (Maybe Child))
handleLookupChild (FindReq ChildKey
key) = RestrictedProcess State State
forall s. RestrictedProcess s s
getState RestrictedProcess State State
-> (State -> RestrictedProcess State (Result (Maybe Child)))
-> RestrictedProcess State (Result (Maybe Child))
forall a b.
RestrictedProcess State a
-> (a -> RestrictedProcess State b) -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Child -> RestrictedProcess State (Result (Maybe Child))
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply (Maybe Child -> RestrictedProcess State (Result (Maybe Child)))
-> (State -> Maybe Child)
-> State
-> RestrictedProcess State (Result (Maybe Child))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildKey -> State -> Maybe Child
findChild ChildKey
key

handleListChildren :: ListReq
                   -> RestrictedProcess State (Result [Child])
handleListChildren :: ListReq -> RestrictedProcess State (Result [Child])
handleListChildren ListReq
_ = RestrictedProcess State State
forall s. RestrictedProcess s s
getState RestrictedProcess State State
-> (State -> RestrictedProcess State (Result [Child]))
-> RestrictedProcess State (Result [Child])
forall a b.
RestrictedProcess State a
-> (a -> RestrictedProcess State b) -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Child] -> RestrictedProcess State (Result [Child])
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply ([Child] -> RestrictedProcess State (Result [Child]))
-> (State -> [Child])
-> State
-> RestrictedProcess State (Result [Child])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpecs -> [Child]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ChildSpecs -> [Child])
-> (State -> ChildSpecs) -> State -> [Child]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs)

handleAddChild :: AddChildReq
               -> RestrictedProcess State (Result AddChildResult)
handleAddChild :: AddChildReq -> RestrictedProcess State (Result AddChildResult)
handleAddChild AddChildReq
req = RestrictedProcess State State
forall s. RestrictedProcess s s
getState RestrictedProcess State State
-> (State -> RestrictedProcess State AddChildRes)
-> RestrictedProcess State AddChildRes
forall a b.
RestrictedProcess State a
-> (a -> RestrictedProcess State b) -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AddChildRes -> RestrictedProcess State AddChildRes
forall a. a -> RestrictedProcess State a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddChildRes -> RestrictedProcess State AddChildRes)
-> (State -> AddChildRes)
-> State
-> RestrictedProcess State AddChildRes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddChildReq -> ImmediateStart -> State -> AddChildRes
doAddChild AddChildReq
req ImmediateStart
True RestrictedProcess State AddChildRes
-> (AddChildRes -> RestrictedProcess State (Result AddChildResult))
-> RestrictedProcess State (Result AddChildResult)
forall a b.
RestrictedProcess State a
-> (a -> RestrictedProcess State b) -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AddChildRes -> RestrictedProcess State (Result AddChildResult)
doReply
  where doReply :: AddChildRes -> RestrictedProcess State (Result AddChildResult)
        doReply :: AddChildRes -> RestrictedProcess State (Result AddChildResult)
doReply (Added  State
s) = State -> RestrictedProcess State ()
forall s. s -> RestrictedProcess s ()
putState State
s RestrictedProcess State ()
-> RestrictedProcess State (Result AddChildResult)
-> RestrictedProcess State (Result AddChildResult)
forall a b.
RestrictedProcess State a
-> RestrictedProcess State b -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AddChildResult -> RestrictedProcess State (Result AddChildResult)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply (ChildRef -> AddChildResult
ChildAdded ChildRef
ChildStopped)
        doReply (Exists ChildRef
e) = AddChildResult -> RestrictedProcess State (Result AddChildResult)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply (StartFailure -> AddChildResult
ChildFailedToStart (StartFailure -> AddChildResult) -> StartFailure -> AddChildResult
forall a b. (a -> b) -> a -> b
$ ChildRef -> StartFailure
StartFailureDuplicateChild ChildRef
e)

handleIgnore :: IgnoreChildReq
                     -> RestrictedProcess State RestrictedAction
handleIgnore :: IgnoreChildReq -> RestrictedProcess State RestrictedAction
handleIgnore (IgnoreChildReq SupervisorPid
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
state <- RestrictedProcess State State
forall s. RestrictedProcess s s
getState
  let (Maybe ChildKey
cId, Map SupervisorPid ChildKey
active') =
        (SupervisorPid -> ChildKey -> Maybe ChildKey)
-> SupervisorPid
-> Map SupervisorPid ChildKey
-> (Maybe ChildKey, Map SupervisorPid ChildKey)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\SupervisorPid
_ ChildKey
_ -> Maybe ChildKey
forall a. Maybe a
Nothing) SupervisorPid
childPid (Map SupervisorPid ChildKey
 -> (Maybe ChildKey, Map SupervisorPid ChildKey))
-> Map SupervisorPid ChildKey
-> (Maybe ChildKey, Map SupervisorPid ChildKey)
forall a b. (a -> b) -> a -> b
$ State
state State
-> Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey
forall r a. r -> T r a -> a
^. Accessor State (Map SupervisorPid ChildKey)
active
  case Maybe ChildKey
cId of
    Maybe ChildKey
Nothing -> RestrictedProcess State RestrictedAction
forall s. RestrictedProcess s RestrictedAction
Restricted.continue
    Just ChildKey
c  -> do
      State -> RestrictedProcess State ()
forall s. s -> RestrictedProcess s ()
putState (State -> RestrictedProcess State ())
-> State -> RestrictedProcess State ()
forall a b. (a -> b) -> a -> b
$ ( (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
active')
                 (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildKey -> State -> State
resetChildIgnored ChildKey
c)
                 (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state
                 )
      RestrictedProcess State RestrictedAction
forall s. RestrictedProcess s RestrictedAction
Restricted.continue
  where
    resetChildIgnored :: ChildKey -> State -> State
    resetChildIgnored :: ChildKey -> State -> State
resetChildIgnored ChildKey
key State
state =
      State -> (State -> State) -> Maybe State -> State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe State
state State -> State
forall a. a -> a
id (Maybe State -> State) -> Maybe State -> State
forall a b. (a -> b) -> a -> b
$ ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
key (ImmediateStart
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildStopped ImmediateStart
True) State
state

handleDeleteChild :: DeleteChild
                  -> RestrictedProcess State (Result DeleteChildResult)
handleDeleteChild :: DeleteChild -> RestrictedProcess State (Result DeleteChildResult)
handleDeleteChild (DeleteChild ChildKey
k) = RestrictedProcess State State
forall s. RestrictedProcess s s
getState RestrictedProcess State State
-> (State -> RestrictedProcess State (Result DeleteChildResult))
-> RestrictedProcess State (Result DeleteChildResult)
forall a b.
RestrictedProcess State a
-> (a -> RestrictedProcess State b) -> RestrictedProcess State b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChildKey
-> State -> RestrictedProcess State (Result DeleteChildResult)
handleDelete ChildKey
k
  where
    handleDelete :: ChildKey
                 -> State
                 -> RestrictedProcess State (Result DeleteChildResult)
    handleDelete :: ChildKey
-> State -> RestrictedProcess State (Result DeleteChildResult)
handleDelete ChildKey
key State
state =
      let (ChildSpecs
prefix, ChildSpecs
suffix) = (Child -> ImmediateStart) -> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a. (a -> ImmediateStart) -> Seq a -> (Seq a, Seq a)
Seq.breakl ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildKey
key) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) (ChildSpecs -> (ChildSpecs, ChildSpecs))
-> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a b. (a -> b) -> a -> b
$ State
state State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs
      in case (ChildSpecs -> ViewL Child
forall a. Seq a -> ViewL a
Seq.viewl ChildSpecs
suffix) of
           ViewL Child
EmptyL             -> DeleteChildResult
-> RestrictedProcess State (Result DeleteChildResult)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply DeleteChildResult
ChildNotFound
           Child
child :< ChildSpecs
remaining -> Child
-> ChildSpecs
-> ChildSpecs
-> State
-> RestrictedProcess State (Result DeleteChildResult)
tryDeleteChild Child
child ChildSpecs
prefix ChildSpecs
remaining State
state

    tryDeleteChild :: Child
-> ChildSpecs
-> ChildSpecs
-> State
-> RestrictedProcess State (Result DeleteChildResult)
tryDeleteChild (ChildRef
ref, ChildSpec
spec) ChildSpecs
pfx ChildSpecs
sfx State
st
      | ChildRef
ref ChildRef -> ChildRef -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildRef
ChildStopped = do
          State -> RestrictedProcess State ()
forall s. s -> RestrictedProcess s ()
putState (State -> RestrictedProcess State ())
-> State -> RestrictedProcess State ()
forall a b. (a -> b) -> a -> b
$ ( (Accessor State ChildSpecs
specs Accessor State ChildSpecs -> ChildSpecs -> State -> State
forall r a. T r a -> a -> r -> r
^= ChildSpecs
pfx ChildSpecs -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a -> Seq a
>< ChildSpecs
sfx)
                     (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Specified (ChildSpec -> ChildType
childType ChildSpec
spec) Int -> Int
decrement State
st
                     )
          DeleteChildResult
-> RestrictedProcess State (Result DeleteChildResult)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply DeleteChildResult
ChildDeleted
      | ImmediateStart
otherwise = DeleteChildResult
-> RestrictedProcess State (Result DeleteChildResult)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply (DeleteChildResult
 -> RestrictedProcess State (Result DeleteChildResult))
-> DeleteChildResult
-> RestrictedProcess State (Result DeleteChildResult)
forall a b. (a -> b) -> a -> b
$ ChildRef -> DeleteChildResult
ChildNotStopped ChildRef
ref

handleStartChild :: State
                 -> StartChildReq
                 -> Process (ProcessReply StartChildResult State)
handleStartChild :: CallHandler State StartChildReq StartChildResult
handleStartChild State
state (StartChild ChildKey
key) =
  let child :: Maybe Child
child = ChildKey -> State -> Maybe Child
findChild ChildKey
key State
state in
  case Maybe Child
child of
    Maybe Child
Nothing ->
      StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply StartChildResult
ChildStartUnknownId State
state
    Just (ref :: ChildRef
ref@(ChildRunning SupervisorPid
_), ChildSpec
_) ->
      StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> StartChildResult
ChildStartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ref :: ChildRef
ref@(ChildRunningExtra SupervisorPid
_ Message
_), ChildSpec
_) ->
      StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> StartChildResult
ChildStartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ref :: ChildRef
ref@(ChildRestarting SupervisorPid
_), ChildSpec
_) ->
      StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> StartChildResult
ChildStartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ChildRef
_, ChildSpec
spec) -> do
      Either StartFailure (ChildRef, State)
started <- ChildSpec
-> State -> Process (Either StartFailure (ChildRef, State))
doStartChild ChildSpec
spec State
state
      case Either StartFailure (ChildRef, State)
started of
        Left StartFailure
err         -> StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> StartChildResult
ChildStartFailed StartFailure
err) State
state
        Right (ChildRef
ref, State
st') -> StartChildResult
-> State -> Process (ProcessReply StartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (ChildRef -> StartChildResult
ChildStartOk ChildRef
ref) State
st'

handleStartNewChild :: State
                 -> AddChildReq
                 -> Process (ProcessReply AddChildResult State)
handleStartNewChild :: CallHandler State AddChildReq AddChildResult
handleStartNewChild State
state req :: AddChildReq
req@(AddChild ImmediateStart
_ ChildSpec
spec) =
  let added :: AddChildRes
added = AddChildReq -> ImmediateStart -> State -> AddChildRes
doAddChild AddChildReq
req ImmediateStart
False State
state in
  case AddChildRes
added of
    Exists ChildRef
e -> AddChildResult
-> State -> Process (ProcessReply AddChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> AddChildResult
ChildFailedToStart (StartFailure -> AddChildResult) -> StartFailure -> AddChildResult
forall a b. (a -> b) -> a -> b
$ ChildRef -> StartFailure
StartFailureDuplicateChild ChildRef
e) State
state
    Added  State
_ -> State -> ChildSpec -> Process (ProcessReply AddChildResult State)
attemptStart State
state ChildSpec
spec
  where
    attemptStart :: State -> ChildSpec -> Process (ProcessReply AddChildResult State)
attemptStart State
st ChildSpec
ch = do
      Either StartFailure ChildRef
started <- ChildSpec -> Process (Either StartFailure ChildRef)
tryStartChild ChildSpec
ch
      case Either StartFailure ChildRef
started of
        Left StartFailure
err  -> AddChildResult
-> State -> Process (ProcessReply AddChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> AddChildResult
ChildFailedToStart StartFailure
err) (State -> Process (ProcessReply AddChildResult State))
-> State -> Process (ProcessReply AddChildResult State)
forall a b. (a -> b) -> a -> b
$ ChildSpec -> State -> State
removeChild ChildSpec
spec State
st -- TODO: document this!
        Right ChildRef
ref -> do
          let st' :: State
st' = ( (Accessor State ChildSpecs
specs Accessor State ChildSpecs
-> (ChildSpecs -> ChildSpecs) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: (ChildSpecs -> Child -> ChildSpecs
forall a. Seq a -> a -> Seq a
|> (ChildRef
ref, ChildSpec
spec)))
                    (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Specified (ChildSpec -> ChildType
childType ChildSpec
spec) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) State
st
                    )
            in AddChildResult
-> State -> Process (ProcessReply AddChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (ChildRef -> AddChildResult
ChildAdded ChildRef
ref) (State -> Process (ProcessReply AddChildResult State))
-> State -> Process (ProcessReply AddChildResult State)
forall a b. (a -> b) -> a -> b
$ State -> ChildRef -> ChildSpec -> State
markActive State
st' ChildRef
ref ChildSpec
ch

handleRestartChild :: State
                   -> RestartChildReq
                   -> Process (ProcessReply RestartChildResult State)
handleRestartChild :: CallHandler State RestartChildReq RestartChildResult
handleRestartChild State
state (RestartChildReq ChildKey
key) =
  let child :: Maybe Child
child = ChildKey -> State -> Maybe Child
findChild ChildKey
key State
state in
  case Maybe Child
child of
    Maybe Child
Nothing ->
      RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply RestartChildResult
ChildRestartUnknownId State
state
    Just (ref :: ChildRef
ref@(ChildRunning SupervisorPid
_), ChildSpec
_) ->
      RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> RestartChildResult
ChildRestartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ref :: ChildRef
ref@(ChildRunningExtra SupervisorPid
_ Message
_), ChildSpec
_) ->
      RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> RestartChildResult
ChildRestartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ref :: ChildRef
ref@(ChildRestarting SupervisorPid
_), ChildSpec
_) ->
      RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> RestartChildResult
ChildRestartFailed (ChildRef -> StartFailure
StartFailureAlreadyRunning ChildRef
ref)) State
state
    Just (ChildRef
_, ChildSpec
spec) -> do
      Either StartFailure (ChildRef, State)
started <- ChildSpec
-> State -> Process (Either StartFailure (ChildRef, State))
doStartChild ChildSpec
spec State
state
      case Either StartFailure (ChildRef, State)
started of
        Left StartFailure
err         -> RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (StartFailure -> RestartChildResult
ChildRestartFailed StartFailure
err) State
state
        Right (ChildRef
ref, State
st') -> RestartChildResult
-> State -> Process (ProcessReply RestartChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply (ChildRef -> RestartChildResult
ChildRestartOk ChildRef
ref) State
st'

handleDelayedRestart :: State
                     -> DelayedRestart
                     -> Process (ProcessAction State)
handleDelayedRestart :: ActionHandler State DelayedRestart
handleDelayedRestart State
state (DelayedRestart ChildKey
key DiedReason
reason) =
  let child :: Maybe Child
child = ChildKey -> State -> Maybe Child
findChild ChildKey
key State
state in do
  case Maybe Child
child of
    Maybe Child
Nothing ->
      State -> Process (ProcessAction State)
forall s. s -> Action s
continue State
state -- a child could've been stopped and removed by now
    Just ((ChildRestarting SupervisorPid
childPid), ChildSpec
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...
      SupervisorPid
-> State
-> Map SupervisorPid ChildKey
-> ChildSpec
-> DiedReason
-> Process (ProcessAction State)
tryRestartChild SupervisorPid
childPid State
state (State
state State
-> Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey
forall r a. r -> T r a -> a
^. Accessor State (Map SupervisorPid ChildKey)
active) ChildSpec
spec DiedReason
reason
    Just Child
other -> do
      ExitReason -> Process (ProcessAction State)
forall a b. Serializable a => a -> Process b
die (ExitReason -> Process (ProcessAction State))
-> ExitReason -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ ChildKey -> ExitReason
ExitOther (ChildKey -> ExitReason) -> ChildKey -> ExitReason
forall a b. (a -> b) -> a -> b
$ (ShowS
supErrId ChildKey
".handleDelayedRestart:InvalidState: ") ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ (Child -> ChildKey
forall a. Show a => a -> ChildKey
show Child
other)

handleStopChild :: State
                     -> StopChildReq
                     -> Process (ProcessReply StopChildResult State)
handleStopChild :: CallHandler State StopChildReq StopChildResult
handleStopChild State
state (StopChildReq ChildKey
key) =
  let child :: Maybe Child
child = ChildKey -> State -> Maybe Child
findChild ChildKey
key State
state in
  case Maybe Child
child of
    Maybe Child
Nothing ->
      StopChildResult
-> State -> Process (ProcessReply StopChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply StopChildResult
StopChildUnknownId State
state
    Just (ChildRef
ChildStopped, ChildSpec
_) ->
      StopChildResult
-> State -> Process (ProcessReply StopChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply StopChildResult
StopChildOk State
state
    Just (ChildRef
ref, ChildSpec
spec) ->
      StopChildResult
-> State -> Process (ProcessReply StopChildResult State)
forall r s. Serializable r => r -> s -> Reply r s
reply StopChildResult
StopChildOk (State -> Process (ProcessReply StopChildResult State))
-> Process State -> Process (ProcessReply StopChildResult State)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChildRef -> ChildSpec -> State -> Process State
doStopChild ChildRef
ref ChildSpec
spec State
state

handleGetStats :: StatsReq
               -> RestrictedProcess State (Result SupervisorStats)
handleGetStats :: StatsReq -> RestrictedProcess State (Result SupervisorStats)
handleGetStats StatsReq
_ = SupervisorStats -> RestrictedProcess State (Result SupervisorStats)
forall s r. Serializable r => r -> RestrictedProcess s (Result r)
Restricted.reply (SupervisorStats
 -> RestrictedProcess State (Result SupervisorStats))
-> (State -> SupervisorStats)
-> State
-> RestrictedProcess State (Result SupervisorStats)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> T State SupervisorStats -> SupervisorStats
forall r a. r -> T r a -> a
^. T State SupervisorStats
stats) (State -> RestrictedProcess State (Result SupervisorStats))
-> RestrictedProcess State State
-> RestrictedProcess State (Result SupervisorStats)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RestrictedProcess State State
forall s. RestrictedProcess s s
getState

--------------------------------------------------------------------------------
-- Child Monitoring                                                           --
--------------------------------------------------------------------------------

handleMonitorSignal :: State
                    -> ProcessMonitorNotification
                    -> Process (ProcessAction State)
handleMonitorSignal :: ActionHandler State ProcessMonitorNotification
handleMonitorSignal State
state (ProcessMonitorNotification MonitorRef
_ SupervisorPid
childPid DiedReason
reason) = do
  let (Maybe ChildKey
cId, Map SupervisorPid ChildKey
active') =
        (SupervisorPid -> ChildKey -> Maybe ChildKey)
-> SupervisorPid
-> Map SupervisorPid ChildKey
-> (Maybe ChildKey, Map SupervisorPid ChildKey)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\SupervisorPid
_ ChildKey
_ -> Maybe ChildKey
forall a. Maybe a
Nothing) SupervisorPid
childPid (Map SupervisorPid ChildKey
 -> (Maybe ChildKey, Map SupervisorPid ChildKey))
-> Map SupervisorPid ChildKey
-> (Maybe ChildKey, Map SupervisorPid ChildKey)
forall a b. (a -> b) -> a -> b
$ State
state State
-> Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey
forall r a. r -> T r a -> a
^. Accessor State (Map SupervisorPid ChildKey)
active
  let mSpec :: Maybe ChildSpec
mSpec =
        case Maybe ChildKey
cId of
          Maybe ChildKey
Nothing -> Maybe ChildSpec
forall a. Maybe a
Nothing
          Just ChildKey
c  -> (Child -> ChildSpec) -> Maybe Child -> Maybe ChildSpec
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Child -> ChildSpec
forall a b. (a, b) -> b
snd (Maybe Child -> Maybe ChildSpec) -> Maybe Child -> Maybe ChildSpec
forall a b. (a -> b) -> a -> b
$ ChildKey -> State -> Maybe Child
findChild ChildKey
c State
state
  case Maybe ChildSpec
mSpec of
    Maybe ChildSpec
Nothing   -> State -> Process (ProcessAction State)
forall s. s -> Action s
continue (State -> Process (ProcessAction State))
-> State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
active') State
state
    Just ChildSpec
spec -> SupervisorPid
-> State
-> Map SupervisorPid ChildKey
-> ChildSpec
-> DiedReason
-> Process (ProcessAction State)
tryRestart SupervisorPid
childPid State
state Map SupervisorPid ChildKey
active' ChildSpec
spec DiedReason
reason

--------------------------------------------------------------------------------
-- Child Monitoring                                                           --
--------------------------------------------------------------------------------

handleShutdown :: ExitState State -> ExitReason -> Process ()
handleShutdown :: ExitState State -> ExitReason -> Process ()
handleShutdown ExitState State
state r :: ExitReason
r@(ExitOther ChildKey
reason) = State -> ExitReason -> Process ()
stopChildren (ExitState State -> State
forall s. ExitState s -> s
exitState ExitState State
state) ExitReason
r Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ChildKey -> Process ()
forall a b. Serializable a => a -> Process b
die ChildKey
reason
handleShutdown ExitState State
state ExitReason
r                    = State -> ExitReason -> Process ()
stopChildren (ExitState State -> State
forall s. ExitState s -> s
exitState ExitState State
state) ExitReason
r

--------------------------------------------------------------------------------
-- Child Start/Restart Handling                                               --
--------------------------------------------------------------------------------

tryRestart :: ChildPid
           -> State
           -> Map ChildPid ChildKey
           -> ChildSpec
           -> DiedReason
           -> Process (ProcessAction State)
tryRestart :: SupervisorPid
-> State
-> Map SupervisorPid ChildKey
-> ChildSpec
-> DiedReason
-> Process (ProcessAction State)
tryRestart SupervisorPid
childPid State
state Map SupervisorPid ChildKey
active' ChildSpec
spec DiedReason
reason = do
  SupervisorPid
sup <- Process SupervisorPid
getSelfPid
  (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.debug (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"signalled restart" SupervisorPid
sup (ChildSpec -> ChildKey
childKey ChildSpec
spec) (DiedReason -> ChildKey
forall a. Show a => a -> ChildKey
show DiedReason
reason)
  case State
state State -> Accessor State RestartStrategy -> RestartStrategy
forall r a. r -> T r a -> a
^. Accessor State RestartStrategy
strategy of
    RestartOne RestartLimit
_ -> SupervisorPid
-> State
-> Map SupervisorPid ChildKey
-> ChildSpec
-> DiedReason
-> Process (ProcessAction State)
tryRestartChild SupervisorPid
childPid State
state Map SupervisorPid ChildKey
active' ChildSpec
spec DiedReason
reason
    RestartStrategy
strat        -> do
      case (ChildSpec -> RestartPolicy
childRestart ChildSpec
spec, DiedReason -> ImmediateStart
isNormal DiedReason
reason) of
        (RestartPolicy
Intrinsic, ImmediateStart
True) -> State -> ExitReason -> Process (ProcessAction State)
forall s. s -> ExitReason -> Action s
stopWith State
newState ExitReason
ExitNormal
        (RestartPolicy
Transient, ImmediateStart
True) -> State -> Process (ProcessAction State)
forall s. s -> Action s
continue State
newState
        (RestartPolicy
Temporary, ImmediateStart
_)    -> State -> Process (ProcessAction State)
forall s. s -> Action s
continue State
removeTemp
        (RestartPolicy, ImmediateStart)
_                 -> RestartStrategy
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
tryRestartBranch RestartStrategy
strat ChildSpec
spec DiedReason
reason (State -> Process (ProcessAction State))
-> State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ State
newState
  where
    newState :: State
newState = (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
active') State
state

    removeTemp :: State
removeTemp = ChildSpec -> State -> State
removeChild ChildSpec
spec (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
newState

    isNormal :: DiedReason -> ImmediateStart
isNormal (DiedException ChildKey
_) = ImmediateStart
False
    isNormal DiedReason
_                 = ImmediateStart
True

tryRestartBranch :: RestartStrategy
                 -> ChildSpec
                 -> DiedReason
                 -> State
                 -> Process (ProcessAction State)
tryRestartBranch :: RestartStrategy
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
tryRestartBranch RestartStrategy
rs ChildSpec
sp DiedReason
dr State
st = -- TODO: use DiedReason for logging...
  let mode' :: RestartMode
mode' = RestartStrategy -> RestartMode
mode RestartStrategy
rs
      tree' :: ChildSpecs
tree' = case RestartStrategy
rs of
                RestartAll   RestartLimit
_ RestartMode
_ -> ChildSpecs
childSpecs
                RestartLeft  RestartLimit
_ RestartMode
_ -> ChildSpecs
subTreeL
                RestartRight RestartLimit
_ RestartMode
_ -> ChildSpecs
subTreeR
                RestartStrategy
_                  -> ChildKey -> ChildSpecs
forall a. HasCallStack => ChildKey -> a
error ChildKey
"IllegalState"
      proc :: ChildSpecs -> Process (ProcessAction State)
proc  = case RestartMode
mode' of
                RestartEach     RestartOrder
_ -> RestartOrder -> ChildSpecs -> Process (ProcessAction State)
stopStart (RestartMode -> RestartOrder
order RestartMode
mode')
                RestartMode
_                 -> RestartMode -> ChildSpecs -> Process (ProcessAction State)
restartBranch RestartMode
mode'
    in do SupervisorPid
us <- Process SupervisorPid
getSelfPid
          ProcessAction State
a <- ChildSpecs -> Process (ProcessAction State)
proc ChildSpecs
tree'
          MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid
-> ChildKey -> DiedReason -> RestartStrategy -> MxSupervisor
SupervisorBranchRestarted SupervisorPid
us (ChildSpec -> ChildKey
childKey ChildSpec
sp) DiedReason
dr RestartStrategy
rs
          ProcessAction State -> Process (ProcessAction State)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction State
a
  where
    stopStart :: RestartOrder -> ChildSpecs -> Process (ProcessAction State)
    stopStart :: RestartOrder -> ChildSpecs -> Process (ProcessAction State)
stopStart RestartOrder
order' ChildSpecs
tree = do
      let tree' :: ChildSpecs
tree' = case RestartOrder
order' of
                    RestartOrder
LeftToRight -> ChildSpecs
tree
                    RestartOrder
RightToLeft -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a
Seq.reverse ChildSpecs
tree
      Maybe State
state <- State -> Process (Maybe State)
addRestart State
activeState
      case Maybe State
state of
        Maybe State
Nothing  -> do SupervisorPid
us <- Process SupervisorPid
getSelfPid
                       let reason :: ExitReason
reason = ExitReason
errorMaxIntensityReached
                       MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> ShutdownMode -> ExitReason -> MxSupervisor
SupervisorShutdown SupervisorPid
us (State -> ShutdownMode
shutdownStrategy State
st) ExitReason
reason
                       ExitReason -> Process (ProcessAction State)
forall a b. Serializable a => a -> Process b
die ExitReason
reason
        Just State
st' -> Process State -> Process (ProcessAction State)
apply ((State -> Child -> Process State)
-> State -> ChildSpecs -> Process State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM State -> Child -> Process State
stopStartIt State
st' ChildSpecs
tree')

    restartBranch :: RestartMode -> ChildSpecs -> Process (ProcessAction State)
    restartBranch :: RestartMode -> ChildSpecs -> Process (ProcessAction State)
restartBranch RestartMode
mode' ChildSpecs
tree = do
      Maybe State
state <- State -> Process (Maybe State)
addRestart State
activeState
      case Maybe State
state of
        Maybe State
Nothing  -> ExitReason -> Process (ProcessAction State)
forall a b. Serializable a => a -> Process b
die ExitReason
errorMaxIntensityReached
        Just State
st' -> do
          let (ChildSpecs
stopTree, ChildSpecs
startTree) = RestartMode -> ChildSpecs -> (ChildSpecs, ChildSpecs)
mkTrees RestartMode
mode' ChildSpecs
tree
          (State -> Child -> Process State)
-> State -> ChildSpecs -> Process State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM State -> Child -> Process State
stopIt State
st' ChildSpecs
stopTree Process State
-> (State -> Process (ProcessAction State))
-> Process (ProcessAction State)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
s -> Process State -> Process (ProcessAction State)
apply (Process State -> Process (ProcessAction State))
-> Process State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ (State -> Child -> Process State)
-> State -> ChildSpecs -> Process State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM State -> Child -> Process State
startIt State
s ChildSpecs
startTree

    mkTrees :: RestartMode -> ChildSpecs -> (ChildSpecs, ChildSpecs)
    mkTrees :: RestartMode -> ChildSpecs -> (ChildSpecs, ChildSpecs)
mkTrees (RestartInOrder RestartOrder
LeftToRight)  ChildSpecs
t = (ChildSpecs
t, ChildSpecs
t)
    mkTrees (RestartInOrder RestartOrder
RightToLeft)  ChildSpecs
t = let rev :: ChildSpecs
rev = ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a
Seq.reverse ChildSpecs
t in (ChildSpecs
rev, ChildSpecs
rev)
    mkTrees (RestartRevOrder RestartOrder
LeftToRight) ChildSpecs
t = (ChildSpecs
t, ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a
Seq.reverse ChildSpecs
t)
    mkTrees (RestartRevOrder RestartOrder
RightToLeft) ChildSpecs
t = (ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a
Seq.reverse ChildSpecs
t, ChildSpecs
t)
    mkTrees RestartMode
_                             ChildSpecs
_    = ChildKey -> (ChildSpecs, ChildSpecs)
forall a. HasCallStack => ChildKey -> a
error ChildKey
"mkTrees.INVALID_STATE"

    stopStartIt :: State -> Child -> Process State
    stopStartIt :: State -> Child -> Process State
stopStartIt State
s ch :: Child
ch@(ChildRef
cr, ChildSpec
cs) = do
      SupervisorPid
us <- Process SupervisorPid
getSelfPid
      Maybe SupervisorPid
cPid <- ChildRef -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve ChildRef
cr
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid
-> Maybe SupervisorPid -> ChildKey -> ExitReason -> MxSupervisor
SupervisedChildRestarting SupervisorPid
us Maybe SupervisorPid
cPid (ChildSpec -> ChildKey
childKey ChildSpec
cs) (ChildKey -> ExitReason
ExitOther ChildKey
"RestartedBySupervisor")
      ChildRef -> ChildSpec -> State -> Process State
doStopChild ChildRef
cr ChildSpec
cs State
s Process State -> (State -> Process State) -> Process State
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((State -> Child -> Process State)
-> Child -> State -> Process State
forall a b c. (a -> b -> c) -> b -> a -> c
flip State -> Child -> Process State
startIt) Child
ch

    stopIt :: State -> Child -> Process State
    stopIt :: State -> Child -> Process State
stopIt State
s (ChildRef
cr, ChildSpec
cs) = do
      SupervisorPid
us <- Process SupervisorPid
getSelfPid
      Maybe SupervisorPid
cPid <- ChildRef -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve ChildRef
cr
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid
-> Maybe SupervisorPid -> ChildKey -> ExitReason -> MxSupervisor
SupervisedChildRestarting SupervisorPid
us Maybe SupervisorPid
cPid (ChildSpec -> ChildKey
childKey ChildSpec
cs) (ChildKey -> ExitReason
ExitOther ChildKey
"RestartedBySupervisor")
      ChildRef -> ChildSpec -> State -> Process State
doStopChild ChildRef
cr ChildSpec
cs State
s

    startIt :: State -> Child -> Process State
    startIt :: State -> Child -> Process State
startIt State
s (ChildRef
_, ChildSpec
cs)
      | RestartPolicy -> ImmediateStart
isTemporary (ChildSpec -> RestartPolicy
childRestart ChildSpec
cs) = State -> Process State
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Process State) -> State -> Process State
forall a b. (a -> b) -> a -> b
$ ChildSpec -> State -> State
removeChild ChildSpec
cs State
s
      | ImmediateStart
otherwise                     = ChildSpec -> Either StartFailure (ChildRef, State) -> Process State
ensureActive ChildSpec
cs (Either StartFailure (ChildRef, State) -> Process State)
-> Process (Either StartFailure (ChildRef, State)) -> Process State
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChildSpec
-> State -> Process (Either StartFailure (ChildRef, State))
doStartChild ChildSpec
cs State
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 :: ChildSpec -> Either StartFailure (ChildRef, State) -> Process State
ensureActive ChildSpec
cs Either StartFailure (ChildRef, State)
it
      | (Right (ChildRef
ref, State
st')) <- Either StartFailure (ChildRef, State)
it = State -> Process State
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Process State) -> State -> Process State
forall a b. (a -> b) -> a -> b
$ State -> ChildRef -> ChildSpec -> State
markActive State
st' ChildRef
ref ChildSpec
cs
      | (Left StartFailure
err) <- Either StartFailure (ChildRef, State)
it = ExitReason -> Process State
forall a b. Serializable a => a -> Process b
die (ExitReason -> Process State) -> ExitReason -> Process State
forall a b. (a -> b) -> a -> b
$ ChildKey -> ExitReason
ExitOther (ChildKey -> ExitReason) -> ChildKey -> ExitReason
forall a b. (a -> b) -> a -> b
$ ChildKey
branchErrId ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ (ChildSpec -> ChildKey
childKey ChildSpec
cs) ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
": " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ (StartFailure -> ChildKey
forall a. Show a => a -> ChildKey
show StartFailure
err)
      | ImmediateStart
otherwise = ChildKey -> Process State
forall a. HasCallStack => ChildKey -> a
error ChildKey
"IllegalState"

    branchErrId :: String
    branchErrId :: ChildKey
branchErrId = ShowS
supErrId ChildKey
".tryRestartBranch:child="

    apply :: (Process State) -> Process (ProcessAction State)
    apply :: Process State -> Process (ProcessAction State)
apply Process State
proc = do
      Process (ProcessAction State)
-> (SupervisorPid -> ExitReason -> Process (ProcessAction State))
-> Process (ProcessAction State)
forall a b.
(Show a, Serializable a) =>
Process b -> (SupervisorPid -> a -> Process b) -> Process b
catchExit (Process State
proc Process State
-> (State -> Process (ProcessAction State))
-> Process (ProcessAction State)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= State -> Process (ProcessAction State)
forall s. s -> Action s
continue) (\(SupervisorPid
_ :: ProcessId) -> ExitReason -> Process (ProcessAction State)
forall s. ExitReason -> Action s
stop)

    activeState :: State
activeState = State -> (State -> State) -> Maybe State -> State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe State
st State -> State
forall a. a -> a
id (Maybe State -> State) -> Maybe State -> State
forall a b. (a -> b) -> a -> b
$ ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild (ChildSpec -> ChildKey
childKey ChildSpec
sp)
                                            (ImmediateStart
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildStopped ImmediateStart
False) State
st

    subTreeL :: ChildSpecs
    subTreeL :: ChildSpecs
subTreeL =
      let (ChildSpecs
prefix, ChildSpecs
suffix) = ((Child -> ImmediateStart)
 -> ChildSpecs -> (ChildSpecs, ChildSpecs))
-> (ChildSpecs, ChildSpecs)
forall {a} {t}.
(((a, ChildSpec) -> ImmediateStart) -> ChildSpecs -> t) -> t
splitTree (Child -> ImmediateStart) -> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a. (a -> ImmediateStart) -> Seq a -> (Seq a, Seq a)
Seq.breakl
      in case (ChildSpecs -> ViewL Child
forall a. Seq a -> ViewL a
Seq.viewl ChildSpecs
suffix) of
           Child
child :< ChildSpecs
_ -> ChildSpecs
prefix ChildSpecs -> Child -> ChildSpecs
forall a. Seq a -> a -> Seq a
|> Child
child
           ViewL Child
EmptyL     -> ChildSpecs
prefix

    subTreeR :: ChildSpecs
    subTreeR :: ChildSpecs
subTreeR =
      let (ChildSpecs
prefix, ChildSpecs
suffix) = ((Child -> ImmediateStart)
 -> ChildSpecs -> (ChildSpecs, ChildSpecs))
-> (ChildSpecs, ChildSpecs)
forall {a} {t}.
(((a, ChildSpec) -> ImmediateStart) -> ChildSpecs -> t) -> t
splitTree (Child -> ImmediateStart) -> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a. (a -> ImmediateStart) -> Seq a -> (Seq a, Seq a)
Seq.breakr
      in case (ChildSpecs -> ViewR Child
forall a. Seq a -> ViewR a
Seq.viewr ChildSpecs
suffix) of
           ChildSpecs
_ :> Child
child -> Child
child Child -> ChildSpecs -> ChildSpecs
forall a. a -> Seq a -> Seq a
<| ChildSpecs
prefix
           ViewR Child
EmptyR     -> ChildSpecs
prefix

    splitTree :: (((a, ChildSpec) -> ImmediateStart) -> ChildSpecs -> t) -> t
splitTree ((a, ChildSpec) -> ImmediateStart) -> ChildSpecs -> t
splitWith = ((a, ChildSpec) -> ImmediateStart) -> ChildSpecs -> t
splitWith ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildSpec -> ChildKey
childKey ChildSpec
sp) (ChildKey -> ImmediateStart)
-> ((a, ChildSpec) -> ChildKey) -> (a, ChildSpec) -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> ((a, ChildSpec) -> ChildSpec) -> (a, ChildSpec) -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ChildSpec) -> ChildSpec
forall a b. (a, b) -> b
snd) ChildSpecs
childSpecs

    childSpecs :: ChildSpecs
    childSpecs :: ChildSpecs
childSpecs =
      let cs :: ChildSpecs
cs  = State
activeState State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs
          ck :: ChildKey
ck  = ChildSpec -> ChildKey
childKey ChildSpec
sp
          rs' :: RestartPolicy
rs' = ChildSpec -> RestartPolicy
childRestart ChildSpec
sp
      in case (RestartPolicy -> ImmediateStart
isTransient RestartPolicy
rs', RestartPolicy -> ImmediateStart
isTemporary RestartPolicy
rs', DiedReason
dr) of
           (ImmediateStart
True, ImmediateStart
_, DiedReason
DiedNormal) -> (Child -> ImmediateStart) -> ChildSpecs -> ChildSpecs
forall a. (a -> ImmediateStart) -> Seq a -> Seq a
filter ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= ChildKey
ck) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) ChildSpecs
cs
           (ImmediateStart
_, ImmediateStart
True, DiedReason
_)          -> (Child -> ImmediateStart) -> ChildSpecs -> ChildSpecs
forall a. (a -> ImmediateStart) -> Seq a -> Seq a
filter ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= ChildKey
ck) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) ChildSpecs
cs
           (ImmediateStart, ImmediateStart, DiedReason)
_                     -> ChildSpecs
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 stop
      -- the branch in parallel, but wait on all the exits and then
      -- restart sequentially (based on 'order'). That's not what the
      -- 'RestartParallel' mode advertised, but more importantly, it's
      -- not clear what the semantics for error handling (viz restart errors)
      -- should actually be.

      asyncs <- forM (toList tree') $ \ch -> async $ asyncStop ch
      (_errs, st') <- foldlM collectExits ([], activeState) asyncs
      -- TODO: report errs
      apply $ foldlM startIt st' tree'
      where
        asyncStop :: Child -> Process (Maybe (ChildKey, ChildPid))
        asyncStop (cr, cs) = do
          mPid <- resolve cr
          case mPid of
            Nothing  -> return Nothing
            Just childPid -> do
              void $ doStopChild 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 :: SupervisorPid
-> State
-> Map SupervisorPid ChildKey
-> ChildSpec
-> DiedReason
-> Process (ProcessAction State)
tryRestartChild SupervisorPid
childPid State
st Map SupervisorPid ChildKey
active' ChildSpec
spec DiedReason
reason
  | DiedReason
DiedNormal <- DiedReason
reason
  , ImmediateStart
True       <- RestartPolicy -> ImmediateStart
isTransient (ChildSpec -> RestartPolicy
childRestart ChildSpec
spec) = State -> Process (ProcessAction State)
forall s. s -> Action s
continue State
childDown
  | ImmediateStart
True       <- RestartPolicy -> ImmediateStart
isTemporary (ChildSpec -> RestartPolicy
childRestart ChildSpec
spec) = State -> Process (ProcessAction State)
forall s. s -> Action s
continue State
childRemoved
  | DiedReason
DiedNormal <- DiedReason
reason
  , ImmediateStart
True       <- RestartPolicy -> ImmediateStart
isIntrinsic (ChildSpec -> RestartPolicy
childRestart ChildSpec
spec) = State -> ExitReason -> Process (ProcessAction State)
forall s. s -> ExitReason -> Action s
stopWith State
updateStopped ExitReason
ExitNormal
  | ImmediateStart
otherwise     = SupervisorPid
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
doRestartChild SupervisorPid
childPid ChildSpec
spec DiedReason
reason State
st
  where
    childDown :: State
childDown     = (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
active') (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
updateStopped
    childRemoved :: State
childRemoved  = (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
active') (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ ChildSpec -> State -> State
removeChild ChildSpec
spec State
st
    updateStopped :: State
updateStopped = State -> (State -> State) -> Maybe State -> State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe State
st State -> State
forall a. a -> a
id (Maybe State -> State) -> Maybe State -> State
forall a b. (a -> b) -> a -> b
$ ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
chKey (ImmediateStart
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildStopped ImmediateStart
False) State
st
    chKey :: ChildKey
chKey         = ChildSpec -> ChildKey
childKey ChildSpec
spec

doRestartChild :: ChildPid -> ChildSpec -> DiedReason -> State -> Process (ProcessAction State)
doRestartChild :: SupervisorPid
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
doRestartChild SupervisorPid
pid ChildSpec
spec DiedReason
reason State
state = do -- TODO: use ChildPid and DiedReason to log
  Maybe State
state' <- State -> Process (Maybe State)
addRestart State
state
  case Maybe State
state' of
    Maybe State
Nothing -> -- die errorMaxIntensityReached
      case (ChildSpec -> Maybe TimeInterval
childRestartDelay ChildSpec
spec) of
        Maybe TimeInterval
Nothing  -> ExitReason -> Process (ProcessAction State)
forall a b. Serializable a => a -> Process b
die ExitReason
errorMaxIntensityReached
        Just TimeInterval
del -> SupervisorPid
-> TimeInterval
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
doRestartDelay SupervisorPid
pid TimeInterval
del ChildSpec
spec DiedReason
reason State
state
    Just State
st -> do
      SupervisorPid
sup <- Process SupervisorPid
getSelfPid
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid
-> Maybe SupervisorPid -> ChildKey -> ExitReason -> MxSupervisor
SupervisedChildRestarting SupervisorPid
sup (SupervisorPid -> Maybe SupervisorPid
forall a. a -> Maybe a
Just SupervisorPid
pid) (ChildSpec -> ChildKey
childKey ChildSpec
spec) (ChildKey -> ExitReason
ExitOther (ChildKey -> ExitReason) -> ChildKey -> ExitReason
forall a b. (a -> b) -> a -> b
$ DiedReason -> ChildKey
forall a. Show a => a -> ChildKey
show DiedReason
reason)
      Either StartFailure (ChildRef, State)
start' <- ChildSpec
-> State -> Process (Either StartFailure (ChildRef, State))
doStartChild ChildSpec
spec State
st
      case Either StartFailure (ChildRef, State)
start' of
        Right (ChildRef
ref, State
st') -> State -> Process (ProcessAction State)
forall s. s -> Action s
continue (State -> Process (ProcessAction State))
-> State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ State -> ChildRef -> ChildSpec -> State
markActive State
st' ChildRef
ref ChildSpec
spec
        Left StartFailure
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).
          if RestartPolicy -> ImmediateStart
isTemporary (ChildSpec -> RestartPolicy
childRestart ChildSpec
spec)
             then do
               (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.warning (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$
                 ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"Error in temporary child" SupervisorPid
sup (ChildSpec -> ChildKey
childKey ChildSpec
spec) (StartFailure -> ChildKey
forall a. Show a => a -> ChildKey
show StartFailure
err)
               State -> Process (ProcessAction State)
forall s. s -> Action s
continue (State -> Process (ProcessAction State))
-> State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ ( (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey)
-> State
-> State
forall r a. T r a -> (a -> a) -> r -> r
^: (ChildKey -> ImmediateStart)
-> Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey
forall a k. (a -> ImmediateStart) -> Map k a -> Map k a
Map.filter (ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= ChildKey
chKey))
                   (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Active ChildType
chType Int -> Int
decrement)
                   (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Specified ChildType
chType Int -> Int
decrement)
                   (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ ChildSpec -> State -> State
removeChild ChildSpec
spec State
st)
             else do
               (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.error (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$
                 ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"Unrecoverable error in child. Stopping supervisor"
                 SupervisorPid
sup (ChildSpec -> ChildKey
childKey ChildSpec
spec) (StartFailure -> ChildKey
forall a. Show a => a -> ChildKey
show StartFailure
err)
               State -> ExitReason -> Process (ProcessAction State)
forall s. s -> ExitReason -> Action s
stopWith State
st (ExitReason -> Process (ProcessAction State))
-> ExitReason -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ ChildKey -> ExitReason
ExitOther (ChildKey -> ExitReason) -> ChildKey -> ExitReason
forall a b. (a -> b) -> a -> b
$ ChildKey
"Unrecoverable error in child " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ (ChildSpec -> ChildKey
childKey ChildSpec
spec)
  where
    chKey :: ChildKey
chKey  = ChildSpec -> ChildKey
childKey ChildSpec
spec
    chType :: ChildType
chType = ChildSpec -> ChildType
childType ChildSpec
spec


doRestartDelay :: ChildPid
               -> TimeInterval
               -> ChildSpec
               -> DiedReason
               -> State
               -> Process (ProcessAction State)
doRestartDelay :: SupervisorPid
-> TimeInterval
-> ChildSpec
-> DiedReason
-> State
-> Process (ProcessAction State)
doRestartDelay SupervisorPid
oldPid TimeInterval
rDelay ChildSpec
spec DiedReason
reason State
state = do
  TimeInterval
-> DelayedRestart -> State -> Process (ProcessAction State)
forall s m. Serializable m => TimeInterval -> m -> s -> Action s
evalAfter TimeInterval
rDelay
            (ChildKey -> DiedReason -> DelayedRestart
DelayedRestart (ChildSpec -> ChildKey
childKey ChildSpec
spec) DiedReason
reason)
          (State -> Process (ProcessAction State))
-> State -> Process (ProcessAction State)
forall a b. (a -> b) -> a -> b
$ ( (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey)
-> State
-> State
forall r a. T r a -> (a -> a) -> r -> r
^: (ChildKey -> ImmediateStart)
-> Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey
forall a k. (a -> ImmediateStart) -> Map k a -> Map k a
Map.filter (ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= ChildKey
chKey))
            (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Active ChildType
chType Int -> Int
decrement)
            -- . (restarts ^= [])
            (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State -> (State -> State) -> Maybe State -> State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe State
state State -> State
forall a. a -> a
id (ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
chKey (SupervisorPid
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildRestarting SupervisorPid
oldPid) State
state)
            )
  where
    chKey :: ChildKey
chKey  = ChildSpec -> ChildKey
childKey ChildSpec
spec
    chType :: ChildType
chType = ChildSpec -> ChildType
childType ChildSpec
spec

addRestart :: State -> Process (Maybe State)
addRestart :: State -> Process (Maybe State)
addRestart State
state = do
  UTCTime
now <- IO UTCTime -> Process UTCTime
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Process UTCTime) -> IO UTCTime -> Process UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
  let acc :: [UTCTime]
acc = ([UTCTime] -> UTCTime -> [UTCTime])
-> [UTCTime] -> [UTCTime] -> [UTCTime]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UTCTime -> [UTCTime] -> UTCTime -> [UTCTime]
accRestarts UTCTime
now) [] (UTCTime
nowUTCTime -> [UTCTime] -> [UTCTime]
forall a. a -> [a] -> [a]
:[UTCTime]
restarted)
  case [UTCTime] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UTCTime]
acc of
    Int
n | Int
n Int -> Int -> ImmediateStart
forall a. Ord a => a -> a -> ImmediateStart
> Int
maxAttempts -> Maybe State -> Process (Maybe State)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe State
forall a. Maybe a
Nothing
    Int
_                   -> Maybe State -> Process (Maybe State)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe State -> Process (Maybe State))
-> Maybe State -> Process (Maybe State)
forall a b. (a -> b) -> a -> b
$ State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$ (Accessor State [UTCTime]
restarts Accessor State [UTCTime] -> [UTCTime] -> State -> State
forall r a. T r a -> a -> r -> r
^= [UTCTime]
acc) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state
  where
    maxAttempts :: Int
maxAttempts  = MaxRestarts -> Int
maxNumberOfRestarts (MaxRestarts -> Int) -> MaxRestarts -> Int
forall a b. (a -> b) -> a -> b
$ RestartLimit -> MaxRestarts
maxR (RestartLimit -> MaxRestarts) -> RestartLimit -> MaxRestarts
forall a b. (a -> b) -> a -> b
$ RestartLimit
maxIntensity
    slot :: NominalDiffTime
slot         = State
state State -> Accessor State NominalDiffTime -> NominalDiffTime
forall r a. r -> T r a -> a
^. Accessor State NominalDiffTime
restartPeriod
    restarted :: [UTCTime]
restarted    = State
state State -> Accessor State [UTCTime] -> [UTCTime]
forall r a. r -> T r a -> a
^. Accessor State [UTCTime]
restarts
    maxIntensity :: RestartLimit
maxIntensity = State
state State -> T State RestartLimit -> RestartLimit
forall r a. r -> T r a -> a
^. Accessor State RestartStrategy
strategy Accessor State RestartStrategy
-> Accessor RestartStrategy RestartLimit -> T State RestartLimit
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor RestartStrategy RestartLimit
restartIntensity

    accRestarts :: UTCTime -> [UTCTime] -> UTCTime -> [UTCTime]
    accRestarts :: UTCTime -> [UTCTime] -> UTCTime -> [UTCTime]
accRestarts UTCTime
now' [UTCTime]
acc UTCTime
r =
      let diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now' UTCTime
r in
      if NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> ImmediateStart
forall a. Ord a => a -> a -> ImmediateStart
> NominalDiffTime
slot then [UTCTime]
acc else (UTCTime
rUTCTime -> [UTCTime] -> [UTCTime]
forall a. a -> [a] -> [a]
:[UTCTime]
acc)

doStartChild :: ChildSpec
             -> State
             -> Process (Either StartFailure (ChildRef, State))
doStartChild :: ChildSpec
-> State -> Process (Either StartFailure (ChildRef, State))
doStartChild ChildSpec
spec State
st = do
  Either StartFailure ChildRef
restart <- ChildSpec -> Process (Either StartFailure ChildRef)
tryStartChild ChildSpec
spec
  case Either StartFailure ChildRef
restart of
    Left StartFailure
f  -> Either StartFailure (ChildRef, State)
-> Process (Either StartFailure (ChildRef, State))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StartFailure (ChildRef, State)
 -> Process (Either StartFailure (ChildRef, State)))
-> Either StartFailure (ChildRef, State)
-> Process (Either StartFailure (ChildRef, State))
forall a b. (a -> b) -> a -> b
$ StartFailure -> Either StartFailure (ChildRef, State)
forall a b. a -> Either a b
Left StartFailure
f
    Right ChildRef
p -> do
      let mState :: Maybe State
mState = ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
chKey (ChildRef
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
chRunning ChildRef
p) State
st
      case Maybe State
mState of
        -- TODO: better error message if the child is unrecognised
        Maybe State
Nothing -> ChildKey -> Process (Either StartFailure (ChildRef, State))
forall a b. Serializable a => a -> Process b
die (ChildKey -> Process (Either StartFailure (ChildRef, State)))
-> ChildKey -> Process (Either StartFailure (ChildRef, State))
forall a b. (a -> b) -> a -> b
$ (ShowS
supErrId ChildKey
".doStartChild.InternalError:") ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildSpec -> ChildKey
forall a. Show a => a -> ChildKey
show ChildSpec
spec
        Just State
s' -> Either StartFailure (ChildRef, State)
-> Process (Either StartFailure (ChildRef, State))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StartFailure (ChildRef, State)
 -> Process (Either StartFailure (ChildRef, State)))
-> Either StartFailure (ChildRef, State)
-> Process (Either StartFailure (ChildRef, State))
forall a b. (a -> b) -> a -> b
$ (ChildRef, State) -> Either StartFailure (ChildRef, State)
forall a b. b -> Either a b
Right ((ChildRef, State) -> Either StartFailure (ChildRef, State))
-> (ChildRef, State) -> Either StartFailure (ChildRef, State)
forall a b. (a -> b) -> a -> b
$ (ChildRef
p, State -> ChildRef -> ChildSpec -> State
markActive State
s' ChildRef
p ChildSpec
spec)
  where
    chKey :: ChildKey
chKey = ChildSpec -> ChildKey
childKey ChildSpec
spec

    chRunning :: ChildRef -> Child -> Prefix -> Suffix -> State -> Maybe State
    chRunning :: ChildRef
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
chRunning ChildRef
newRef (ChildRef
_, ChildSpec
chSpec) ChildSpecs
prefix ChildSpecs
suffix State
st' =
      State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$ ( (Accessor State ChildSpecs
specs Accessor State ChildSpecs -> ChildSpecs -> State -> State
forall r a. T r a -> a -> r -> r
^= ChildSpecs
prefix ChildSpecs -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a -> Seq a
>< ((ChildRef
newRef, ChildSpec
chSpec) Child -> ChildSpecs -> ChildSpecs
forall a. a -> Seq a -> Seq a
<| ChildSpecs
suffix))
             (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Active (ChildSpec -> ChildType
childType ChildSpec
spec) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) State
st'
             )

tryStartChild :: ChildSpec
              -> Process (Either StartFailure ChildRef)
tryStartChild :: ChildSpec -> Process (Either StartFailure ChildRef)
tryStartChild ChildSpec{ChildKey
Maybe TimeInterval
Maybe RegisteredName
ChildStart
ChildStopPolicy
RestartPolicy
ChildType
childKey :: ChildSpec -> ChildKey
childType :: ChildSpec -> ChildType
childRestart :: ChildSpec -> RestartPolicy
childRestartDelay :: ChildSpec -> Maybe TimeInterval
childKey :: ChildKey
childType :: ChildType
childRestart :: RestartPolicy
childRestartDelay :: Maybe TimeInterval
childStop :: ChildStopPolicy
childStart :: ChildStart
childRegName :: Maybe RegisteredName
childStop :: ChildSpec -> ChildStopPolicy
childStart :: ChildSpec -> ChildStart
childRegName :: ChildSpec -> Maybe RegisteredName
..} =
    case ChildStart
childStart of
      RunClosure Closure (Process ())
proc -> do
        -- TODO: cache your closures!!!
        Either ChildKey (Process ())
mProc <- Process (Either ChildKey (Process ()))
-> (SomeException -> Process (Either ChildKey (Process ())))
-> Process (Either ChildKey (Process ()))
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (Closure (Process ()) -> Process (Process ())
forall a. Typeable a => Closure a -> Process a
unClosure Closure (Process ())
proc Process (Process ())
-> (Process () -> Process (Either ChildKey (Process ())))
-> Process (Either ChildKey (Process ()))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ChildKey (Process ())
-> Process (Either ChildKey (Process ()))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ChildKey (Process ())
 -> Process (Either ChildKey (Process ())))
-> (Process () -> Either ChildKey (Process ()))
-> Process ()
-> Process (Either ChildKey (Process ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Process () -> Either ChildKey (Process ())
forall a b. b -> Either a b
Right)
                       (\(SomeException
e :: SomeException) -> Either ChildKey (Process ())
-> Process (Either ChildKey (Process ()))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ChildKey (Process ())
 -> Process (Either ChildKey (Process ())))
-> Either ChildKey (Process ())
-> Process (Either ChildKey (Process ()))
forall a b. (a -> b) -> a -> b
$ ChildKey -> Either ChildKey (Process ())
forall a b. a -> Either a b
Left (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
e))
        case Either ChildKey (Process ())
mProc of
          Left ChildKey
err -> StartFailure -> Process (Either StartFailure ChildRef)
forall {b}. StartFailure -> Process (Either StartFailure b)
logStartFailure (StartFailure -> Process (Either StartFailure ChildRef))
-> StartFailure -> Process (Either StartFailure ChildRef)
forall a b. (a -> b) -> a -> b
$ ChildKey -> StartFailure
StartFailureBadClosure ChildKey
err
          Right Process ()
p  -> ChildKey -> Maybe RegisteredName -> Process () -> Process ChildRef
wrapClosure ChildKey
childKey Maybe RegisteredName
childRegName Process ()
p Process ChildRef
-> (ChildRef -> Process (Either StartFailure ChildRef))
-> Process (Either StartFailure ChildRef)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either StartFailure ChildRef
-> Process (Either StartFailure ChildRef)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StartFailure ChildRef
 -> Process (Either StartFailure ChildRef))
-> (ChildRef -> Either StartFailure ChildRef)
-> ChildRef
-> Process (Either StartFailure ChildRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildRef -> Either StartFailure ChildRef
forall a b. b -> Either a b
Right
      CreateHandle Closure (SupervisorPid -> Process (SupervisorPid, Message))
fn -> do
        Either ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
mFn <- Process
  (Either
     ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
-> (SomeException
    -> Process
         (Either
            ChildKey (SupervisorPid -> Process (SupervisorPid, Message))))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (Closure (SupervisorPid -> Process (SupervisorPid, Message))
-> Process (SupervisorPid -> Process (SupervisorPid, Message))
forall a. Typeable a => Closure a -> Process a
unClosure Closure (SupervisorPid -> Process (SupervisorPid, Message))
fn Process (SupervisorPid -> Process (SupervisorPid, Message))
-> ((SupervisorPid -> Process (SupervisorPid, Message))
    -> Process
         (Either
            ChildKey (SupervisorPid -> Process (SupervisorPid, Message))))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
 -> Process
      (Either
         ChildKey (SupervisorPid -> Process (SupervisorPid, Message))))
-> ((SupervisorPid -> Process (SupervisorPid, Message))
    -> Either
         ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
-> (SupervisorPid -> Process (SupervisorPid, Message))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SupervisorPid -> Process (SupervisorPid, Message))
-> Either
     ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
forall a b. b -> Either a b
Right)
                     (\(SomeException
e :: SomeException) -> Either ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
 -> Process
      (Either
         ChildKey (SupervisorPid -> Process (SupervisorPid, Message))))
-> Either
     ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
-> Process
     (Either
        ChildKey (SupervisorPid -> Process (SupervisorPid, Message)))
forall a b. (a -> b) -> a -> b
$ ChildKey
-> Either
     ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
forall a b. a -> Either a b
Left (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
e))
        case Either ChildKey (SupervisorPid -> Process (SupervisorPid, Message))
mFn of
          Left ChildKey
err  -> StartFailure -> Process (Either StartFailure ChildRef)
forall {b}. StartFailure -> Process (Either StartFailure b)
logStartFailure (StartFailure -> Process (Either StartFailure ChildRef))
-> StartFailure -> Process (Either StartFailure ChildRef)
forall a b. (a -> b) -> a -> b
$ ChildKey -> StartFailure
StartFailureBadClosure ChildKey
err
          Right SupervisorPid -> Process (SupervisorPid, Message)
fn' -> do
            ChildKey
-> Maybe RegisteredName
-> (SupervisorPid -> Process (SupervisorPid, Message))
-> Process ChildRef
wrapHandle ChildKey
childKey Maybe RegisteredName
childRegName SupervisorPid -> Process (SupervisorPid, Message)
fn' Process ChildRef
-> (ChildRef -> Process (Either StartFailure ChildRef))
-> Process (Either StartFailure ChildRef)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either StartFailure ChildRef
-> Process (Either StartFailure ChildRef)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StartFailure ChildRef
 -> Process (Either StartFailure ChildRef))
-> (ChildRef -> Either StartFailure ChildRef)
-> ChildRef
-> Process (Either StartFailure ChildRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildRef -> Either StartFailure ChildRef
forall a b. b -> Either a b
Right
  where
    logStartFailure :: StartFailure -> Process (Either StartFailure b)
logStartFailure StartFailure
sf = do
      SupervisorPid
sup <- Process SupervisorPid
getSelfPid
      -- logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf)
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> StartFailure -> ChildKey -> MxSupervisor
SupervisedChildStartFailure SupervisorPid
sup StartFailure
sf ChildKey
childKey
      Either StartFailure b -> Process (Either StartFailure b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StartFailure b -> Process (Either StartFailure b))
-> Either StartFailure b -> Process (Either StartFailure b)
forall a b. (a -> b) -> a -> b
$ StartFailure -> Either StartFailure b
forall a b. a -> Either a b
Left StartFailure
sf

    wrapClosure :: ChildKey
                -> Maybe RegisteredName
                -> Process ()
                -> Process ChildRef
    wrapClosure :: ChildKey -> Maybe RegisteredName -> Process () -> Process ChildRef
wrapClosure ChildKey
key Maybe RegisteredName
regName Process ()
proc = do
      SupervisorPid
supervisor <- Process SupervisorPid
getSelfPid
      SupervisorPid
childPid <- Process () -> Process SupervisorPid
spawnLocal (Process () -> Process SupervisorPid)
-> Process () -> Process SupervisorPid
forall a b. (a -> b) -> a -> b
$ do
        SupervisorPid
self <- Process SupervisorPid
getSelfPid
        SupervisorPid -> Process ()
link SupervisorPid
supervisor -- die if our parent dies
        Maybe RegisteredName -> SupervisorPid -> Process ()
maybeRegister Maybe RegisteredName
regName SupervisorPid
self
        () <- Process ()
forall a. Serializable a => Process a
expect    -- wait for a start signal (pid is still private)
        -- we translate `ExitShutdown' into a /normal/ exit
        (Process ()
proc
          Process ()
-> [SupervisorPid -> Message -> Process (Maybe ())] -> Process ()
forall b.
Process b
-> [SupervisorPid -> Message -> Process (Maybe b)] -> Process b
`catchesExit` [
              (\SupervisorPid
_ Message
m -> Message
-> (ExitReason -> ImmediateStart)
-> (ExitReason -> Process ())
-> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> ImmediateStart) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
m (\ExitReason
r -> ExitReason
r ExitReason -> ExitReason -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ExitReason
ExitShutdown)
                                         (\ExitReason
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
            , (\SupervisorPid
_ Message
m -> Message
-> (ExitReason -> ImmediateStart)
-> (ExitReason -> Process ())
-> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> ImmediateStart) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
m (\(ExitOther ChildKey
_) -> ImmediateStart
True)
                                         (\ExitReason
r -> SupervisorPid -> SupervisorPid -> ExitReason -> Process ()
logExit SupervisorPid
supervisor SupervisorPid
self ExitReason
r))
            ])
           Process () -> [Handler ()] -> Process ()
forall a. Process a -> [Handler a] -> Process a
`catches` [ (ChildInitFailure -> Process ()) -> Handler ()
forall a e. Exception e => (e -> Process a) -> Handler a
Handler ((ChildInitFailure -> Process ()) -> Handler ())
-> (ChildInitFailure -> Process ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> SupervisorPid -> ChildInitFailure -> Process ()
filterInitFailures SupervisorPid
supervisor SupervisorPid
self
                     , (SomeException -> Process ()) -> Handler ()
forall a e. Exception e => (e -> Process a) -> Handler a
Handler ((SomeException -> Process ()) -> Handler ())
-> (SomeException -> Process ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> SupervisorPid -> SomeException -> Process ()
logFailure SupervisorPid
supervisor SupervisorPid
self ]
      Process MonitorRef -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process MonitorRef -> Process ())
-> Process MonitorRef -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> Process MonitorRef
monitor SupervisorPid
childPid
      SupervisorPid -> () -> Process ()
forall a. Serializable a => SupervisorPid -> a -> Process ()
send SupervisorPid
childPid ()
      let cRef :: ChildRef
cRef = SupervisorPid -> ChildRef
ChildRunning SupervisorPid
childPid
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> ChildRef -> ChildKey -> MxSupervisor
SupervisedChildStarted SupervisorPid
supervisor ChildRef
cRef ChildKey
key
      ChildRef -> Process ChildRef
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ChildRef
cRef

    wrapHandle :: ChildKey
               -> Maybe RegisteredName
               -> (SupervisorPid -> Process (ChildPid, Message))
               -> Process ChildRef
    wrapHandle :: ChildKey
-> Maybe RegisteredName
-> (SupervisorPid -> Process (SupervisorPid, Message))
-> Process ChildRef
wrapHandle ChildKey
key Maybe RegisteredName
regName SupervisorPid -> Process (SupervisorPid, Message)
proc = do
      SupervisorPid
super <- Process SupervisorPid
getSelfPid
      (SupervisorPid
childPid, Message
msg) <- SupervisorPid -> Process (SupervisorPid, Message)
proc SupervisorPid
super
      Process MonitorRef -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process MonitorRef -> Process ())
-> Process MonitorRef -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> Process MonitorRef
monitor SupervisorPid
childPid
      Maybe RegisteredName -> SupervisorPid -> Process ()
maybeRegister Maybe RegisteredName
regName SupervisorPid
childPid
      let cRef :: ChildRef
cRef = SupervisorPid -> Message -> ChildRef
ChildRunningExtra SupervisorPid
childPid Message
msg
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> ChildRef -> ChildKey -> MxSupervisor
SupervisedChildStarted SupervisorPid
super ChildRef
cRef ChildKey
key
      ChildRef -> Process ChildRef
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ChildRef
cRef

    maybeRegister :: Maybe RegisteredName -> ChildPid -> Process ()
    maybeRegister :: Maybe RegisteredName -> SupervisorPid -> Process ()
maybeRegister Maybe RegisteredName
Nothing                         SupervisorPid
_     = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    maybeRegister (Just (LocalName ChildKey
n))            SupervisorPid
pid   = ChildKey -> SupervisorPid -> Process ()
register ChildKey
n SupervisorPid
pid
    maybeRegister (Just (CustomRegister Closure (SupervisorPid -> Process ())
clj))     SupervisorPid
pid   = do
        -- TODO: cache your closures!!!
        Either ChildKey (SupervisorPid -> Process ())
mProc <- Process (Either ChildKey (SupervisorPid -> Process ()))
-> (SomeException
    -> Process (Either ChildKey (SupervisorPid -> Process ())))
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (Closure (SupervisorPid -> Process ())
-> Process (SupervisorPid -> Process ())
forall a. Typeable a => Closure a -> Process a
unClosure Closure (SupervisorPid -> Process ())
clj Process (SupervisorPid -> Process ())
-> ((SupervisorPid -> Process ())
    -> Process (Either ChildKey (SupervisorPid -> Process ())))
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ChildKey (SupervisorPid -> Process ())
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ChildKey (SupervisorPid -> Process ())
 -> Process (Either ChildKey (SupervisorPid -> Process ())))
-> ((SupervisorPid -> Process ())
    -> Either ChildKey (SupervisorPid -> Process ()))
-> (SupervisorPid -> Process ())
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SupervisorPid -> Process ())
-> Either ChildKey (SupervisorPid -> Process ())
forall a b. b -> Either a b
Right)
                       (\(SomeException
e :: SomeException) -> Either ChildKey (SupervisorPid -> Process ())
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ChildKey (SupervisorPid -> Process ())
 -> Process (Either ChildKey (SupervisorPid -> Process ())))
-> Either ChildKey (SupervisorPid -> Process ())
-> Process (Either ChildKey (SupervisorPid -> Process ()))
forall a b. (a -> b) -> a -> b
$ ChildKey -> Either ChildKey (SupervisorPid -> Process ())
forall a b. a -> Either a b
Left (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
e))
        case Either ChildKey (SupervisorPid -> Process ())
mProc of
          Left ChildKey
err -> ExitReason -> Process ()
forall a b. Serializable a => a -> Process b
die (ExitReason -> Process ()) -> ExitReason -> Process ()
forall a b. (a -> b) -> a -> b
$ ChildKey -> ExitReason
ExitOther (ShowS
forall a. Show a => a -> ChildKey
show ChildKey
err)
          Right SupervisorPid -> Process ()
p  -> SupervisorPid -> Process ()
p SupervisorPid
pid

filterInitFailures :: SupervisorPid
                   -> ChildPid
                   -> ChildInitFailure
                   -> Process ()
filterInitFailures :: SupervisorPid -> SupervisorPid -> ChildInitFailure -> Process ()
filterInitFailures SupervisorPid
sup SupervisorPid
childPid ChildInitFailure
ex = do
  case ChildInitFailure
ex of
    ChildInitFailure ChildKey
_ -> 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)
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> SupervisorPid -> ChildInitFailure -> MxSupervisor
SupervisedChildInitFailed SupervisorPid
sup SupervisorPid
childPid ChildInitFailure
ex
      IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ ChildInitFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO ChildInitFailure
ex
    ChildInitFailure
ChildInitIgnore    -> SupervisorPid -> IgnoreChildReq -> Process ()
forall a m.
(Addressable a, NFSerializable m) =>
a -> m -> Process ()
Unsafe.cast SupervisorPid
sup (IgnoreChildReq -> Process ()) -> IgnoreChildReq -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> IgnoreChildReq
IgnoreChildReq SupervisorPid
childPid

--------------------------------------------------------------------------------
-- Child Stop/Shutdown                                                 --
--------------------------------------------------------------------------------

stopChildren :: State -> ExitReason -> Process ()
stopChildren :: State -> ExitReason -> Process ()
stopChildren State
state ExitReason
er = do
  SupervisorPid
us <- Process SupervisorPid
getSelfPid
  let strat :: ShutdownMode
strat = State -> ShutdownMode
shutdownStrategy State
state
  MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> ShutdownMode -> ExitReason -> MxSupervisor
SupervisorShutdown SupervisorPid
us ShutdownMode
strat ExitReason
er
  case ShutdownMode
strat of
    ShutdownMode
ParallelShutdown -> do
      let allChildren :: [Child]
allChildren = ChildSpecs -> [Child]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ChildSpecs -> [Child]) -> ChildSpecs -> [Child]
forall a b. (a -> b) -> a -> b
$ State
state State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs
      [(MonitorRef, SupervisorPid)]
terminatorPids <- [Child]
-> (Child -> Process (MonitorRef, SupervisorPid))
-> Process [(MonitorRef, SupervisorPid)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Child]
allChildren ((Child -> Process (MonitorRef, SupervisorPid))
 -> Process [(MonitorRef, SupervisorPid)])
-> (Child -> Process (MonitorRef, SupervisorPid))
-> Process [(MonitorRef, SupervisorPid)]
forall a b. (a -> b) -> a -> b
$ \Child
ch -> do
        SupervisorPid
pid <- Process () -> Process SupervisorPid
spawnLocal (Process () -> Process SupervisorPid)
-> Process () -> Process SupervisorPid
forall a b. (a -> b) -> a -> b
$ Process State -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process State -> Process ()) -> Process State -> Process ()
forall a b. (a -> b) -> a -> b
$ Child -> State -> Process State
syncStop Child
ch (State -> Process State) -> State -> Process State
forall a b. (a -> b) -> a -> b
$ (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> Map SupervisorPid ChildKey -> State -> State
forall r a. T r a -> a -> r -> r
^= Map SupervisorPid ChildKey
forall k a. Map k a
Map.empty) State
state
        MonitorRef
mRef <- SupervisorPid -> Process MonitorRef
monitor SupervisorPid
pid
        (MonitorRef, SupervisorPid) -> Process (MonitorRef, SupervisorPid)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorRef
mRef, SupervisorPid
pid)
      [(SupervisorPid, DiedReason)]
terminationErrors <- [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [] ([((MonitorRef, SupervisorPid), ChildSpec)]
 -> Process [(SupervisorPid, DiedReason)])
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
forall a b. (a -> b) -> a -> b
$ [(MonitorRef, SupervisorPid)]
-> [ChildSpec] -> [((MonitorRef, SupervisorPid), ChildSpec)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(MonitorRef, SupervisorPid)]
terminatorPids ((Child -> ChildSpec) -> [Child] -> [ChildSpec]
forall a b. (a -> b) -> [a] -> [b]
map Child -> ChildSpec
forall a b. (a, b) -> b
snd [Child]
allChildren)
      -- it seems these would also be logged individually in doStopChild
      case [(SupervisorPid, DiedReason)]
terminationErrors of
        [] -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [(SupervisorPid, DiedReason)]
_ -> do
          SupervisorPid
sup <- Process SupervisorPid
getSelfPid
          Process () -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.error (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$
            ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"Errors in stopChildren / ParallelShutdown"
            SupervisorPid
sup ChildKey
"n/a" ([(SupervisorPid, DiedReason)] -> ChildKey
forall a. Show a => a -> ChildKey
show [(SupervisorPid, DiedReason)]
terminationErrors)
    SequentialShutdown RestartOrder
ord -> do
      let specs' :: ChildSpecs
specs'      = State
state State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs
      let allChildren :: ChildSpecs
allChildren = case RestartOrder
ord of
                          RestartOrder
RightToLeft -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a
Seq.reverse ChildSpecs
specs'
                          RestartOrder
LeftToRight -> ChildSpecs
specs'
      Process State -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process State -> Process ()) -> Process State -> Process ()
forall a b. (a -> b) -> a -> b
$ (State -> Child -> Process State)
-> State -> [Child] -> Process State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Child -> State -> Process State)
-> State -> Child -> Process State
forall a b c. (a -> b -> c) -> b -> a -> c
flip Child -> State -> Process State
syncStop) State
state (ChildSpecs -> [Child]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ChildSpecs
allChildren)
  where
    syncStop :: Child -> State -> Process State
    syncStop :: Child -> State -> Process State
syncStop (ChildRef
cr, ChildSpec
cs) State
state' = ChildRef -> ChildSpec -> State -> Process State
doStopChild ChildRef
cr ChildSpec
cs State
state'

    collectExits :: [(ProcessId, DiedReason)]
                 -> [((MonitorRef, ProcessId), ChildSpec)]
                 -> Process [(ProcessId, DiedReason)]
    collectExits :: [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [(SupervisorPid, DiedReason)]
errors []   = [(SupervisorPid, DiedReason)]
-> Process [(SupervisorPid, DiedReason)]
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return [(SupervisorPid, DiedReason)]
errors
    collectExits [(SupervisorPid, DiedReason)]
errors [((MonitorRef, SupervisorPid), ChildSpec)]
pids = do
      (MonitorRef
ref, SupervisorPid
pid, DiedReason
reason) <- [Match (MonitorRef, SupervisorPid, DiedReason)]
-> Process (MonitorRef, SupervisorPid, DiedReason)
forall b. [Match b] -> Process b
receiveWait [
          (ProcessMonitorNotification
 -> Process (MonitorRef, SupervisorPid, DiedReason))
-> Match (MonitorRef, SupervisorPid, DiedReason)
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(ProcessMonitorNotification MonitorRef
ref' SupervisorPid
pid' DiedReason
reason') -> do
                    (MonitorRef, SupervisorPid, DiedReason)
-> Process (MonitorRef, SupervisorPid, DiedReason)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorRef
ref', SupervisorPid
pid', DiedReason
reason'))
        ]
      let remaining :: [((MonitorRef, SupervisorPid), ChildSpec)]
remaining = [((MonitorRef, SupervisorPid), ChildSpec)
p | ((MonitorRef, SupervisorPid), ChildSpec)
p <- [((MonitorRef, SupervisorPid), ChildSpec)]
pids, ((MonitorRef, SupervisorPid) -> SupervisorPid
forall a b. (a, b) -> b
snd ((MonitorRef, SupervisorPid) -> SupervisorPid)
-> (MonitorRef, SupervisorPid) -> SupervisorPid
forall a b. (a -> b) -> a -> b
$ ((MonitorRef, SupervisorPid), ChildSpec)
-> (MonitorRef, SupervisorPid)
forall a b. (a, b) -> a
fst ((MonitorRef, SupervisorPid), ChildSpec)
p) SupervisorPid -> SupervisorPid -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= SupervisorPid
pid]
      let spec :: Maybe ChildSpec
spec = (MonitorRef, SupervisorPid)
-> [((MonitorRef, SupervisorPid), ChildSpec)] -> Maybe ChildSpec
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (MonitorRef
ref, SupervisorPid
pid) [((MonitorRef, SupervisorPid), ChildSpec)]
pids
      case (DiedReason
reason, Maybe ChildSpec
spec) of
        (DiedReason
DiedUnknownId, Maybe ChildSpec
_) -> [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [(SupervisorPid, DiedReason)]
errors [((MonitorRef, SupervisorPid), ChildSpec)]
remaining
        (DiedReason
DiedNormal, Maybe ChildSpec
_) -> [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [(SupervisorPid, DiedReason)]
errors [((MonitorRef, SupervisorPid), ChildSpec)]
remaining
        (DiedReason
_, Maybe ChildSpec
Nothing) -> [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [(SupervisorPid, DiedReason)]
errors [((MonitorRef, SupervisorPid), ChildSpec)]
remaining
        (DiedException ChildKey
_, Just ChildSpec
sp') -> do
            if (ChildSpec -> ChildStopPolicy
childStop ChildSpec
sp') ChildStopPolicy -> ChildStopPolicy -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildStopPolicy
StopImmediately
              then [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits [(SupervisorPid, DiedReason)]
errors [((MonitorRef, SupervisorPid), ChildSpec)]
remaining
              else [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits ((SupervisorPid
pid, DiedReason
reason)(SupervisorPid, DiedReason)
-> [(SupervisorPid, DiedReason)] -> [(SupervisorPid, DiedReason)]
forall a. a -> [a] -> [a]
:[(SupervisorPid, DiedReason)]
errors) [((MonitorRef, SupervisorPid), ChildSpec)]
remaining
        (DiedReason, Maybe ChildSpec)
_ -> [(SupervisorPid, DiedReason)]
-> [((MonitorRef, SupervisorPid), ChildSpec)]
-> Process [(SupervisorPid, DiedReason)]
collectExits ((SupervisorPid
pid, DiedReason
reason)(SupervisorPid, DiedReason)
-> [(SupervisorPid, DiedReason)] -> [(SupervisorPid, DiedReason)]
forall a. a -> [a] -> [a]
:[(SupervisorPid, DiedReason)]
errors) [((MonitorRef, SupervisorPid), ChildSpec)]
remaining

doStopChild :: ChildRef -> ChildSpec -> State -> Process State
doStopChild :: ChildRef -> ChildSpec -> State -> Process State
doStopChild ChildRef
ref ChildSpec
spec State
state = do
  SupervisorPid
us <- Process SupervisorPid
getSelfPid
  Maybe SupervisorPid
mPid <- ChildRef -> Process (Maybe SupervisorPid)
forall a. Resolvable a => a -> Process (Maybe SupervisorPid)
resolve ChildRef
ref
  case Maybe SupervisorPid
mPid of
    Maybe SupervisorPid
Nothing  -> State -> Process State
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return State
state -- an already dead child is not an error
    Just SupervisorPid
pid -> do
      DiedReason
stopped <- ChildStopPolicy -> SupervisorPid -> State -> Process DiedReason
childShutdown (ChildSpec -> ChildStopPolicy
childStop ChildSpec
spec) SupervisorPid
pid State
state
      MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> ChildRef -> DiedReason -> MxSupervisor
SupervisedChildStopped SupervisorPid
us ChildRef
ref DiedReason
stopped
      -- state' <- shutdownComplete state pid stopped
      State -> Process State
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Process State) -> State -> Process State
forall a b. (a -> b) -> a -> b
$ ( (Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey)
-> State
-> State
forall r a. T r a -> (a -> a) -> r -> r
^: SupervisorPid
-> Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete SupervisorPid
pid)
               (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
updateStopped
               )
  where
    {-shutdownComplete :: State -> ChildPid -> DiedReason -> Process State-}
    {-shutdownComplete _      _   DiedNormal        = return $ updateStopped-}
    {-shutdownComplete state' pid (r :: DiedReason) = do-}
      {-logShutdown (state' ^. logger) chKey pid r >> return state'-}

    chKey :: ChildKey
chKey         = ChildSpec -> ChildKey
childKey ChildSpec
spec
    updateStopped :: State
updateStopped = State -> (State -> State) -> Maybe State -> State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe State
state State -> State
forall a. a -> a
id (Maybe State -> State) -> Maybe State -> State
forall a b. (a -> b) -> a -> b
$ ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
chKey (ImmediateStart
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildStopped ImmediateStart
False) State
state

childShutdown :: ChildStopPolicy
              -> ChildPid
              -> State
              -> Process DiedReason
childShutdown :: ChildStopPolicy -> SupervisorPid -> State -> Process DiedReason
childShutdown ChildStopPolicy
policy SupervisorPid
childPid State
st = ((forall a. Process a -> Process a) -> Process DiedReason)
-> Process DiedReason
forall b.
HasCallStack =>
((forall a. Process a -> Process a) -> Process b) -> Process b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. Process a -> Process a) -> Process DiedReason)
 -> Process DiedReason)
-> ((forall a. Process a -> Process a) -> Process DiedReason)
-> Process DiedReason
forall a b. (a -> b) -> a -> b
$ \forall a. Process a -> Process a
restore -> do
  case ChildStopPolicy
policy of
    (StopTimeout Delay
t) -> SupervisorPid -> ExitReason -> Process ()
forall a. Serializable a => SupervisorPid -> a -> Process ()
exit SupervisorPid
childPid ExitReason
ExitShutdown Process () -> Process DiedReason -> Process DiedReason
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Process DiedReason -> Process DiedReason)
-> SupervisorPid -> Delay -> State -> Process DiedReason
forall {b}.
(Process DiedReason -> Process b)
-> SupervisorPid -> Delay -> State -> Process b
await Process DiedReason -> Process DiedReason
forall a. Process a -> Process a
restore SupervisorPid
childPid Delay
t State
st
    -- we ignore DiedReason for brutal kills
    ChildStopPolicy
StopImmediately -> do
      SupervisorPid -> ChildKey -> Process ()
kill SupervisorPid
childPid ChildKey
"StoppedBySupervisor"
      Process DiedReason -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process DiedReason -> Process ())
-> Process DiedReason -> Process ()
forall a b. (a -> b) -> a -> b
$ (Process DiedReason -> Process DiedReason)
-> SupervisorPid -> Delay -> State -> Process DiedReason
forall {b}.
(Process DiedReason -> Process b)
-> SupervisorPid -> Delay -> State -> Process b
await Process DiedReason -> Process DiedReason
forall a. Process a -> Process a
restore SupervisorPid
childPid Delay
Infinity State
st
      DiedReason -> Process DiedReason
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return DiedReason
DiedNormal
  where
    await :: (Process DiedReason -> Process b)
-> SupervisorPid -> Delay -> State -> Process b
await Process DiedReason -> Process b
restore' SupervisorPid
childPid' Delay
delay State
state = do
      -- We require and additional monitor here when child shutdown occurs
      -- during a restart which was triggered by the /old/ monitor signal.
      -- Just to be safe, we monitor the child immediately to be sure it goes.
      MonitorRef
mRef <- SupervisorPid -> Process MonitorRef
monitor SupervisorPid
childPid'
      let recv :: Process (Maybe DiedReason)
recv = case Delay
delay of
                   Delay
Infinity -> [Match DiedReason] -> Process DiedReason
forall b. [Match b] -> Process b
receiveWait (MonitorRef -> [Match DiedReason]
matches MonitorRef
mRef) Process DiedReason
-> (DiedReason -> Process (Maybe DiedReason))
-> Process (Maybe DiedReason)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe DiedReason -> Process (Maybe DiedReason)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DiedReason -> Process (Maybe DiedReason))
-> (DiedReason -> Maybe DiedReason)
-> DiedReason
-> Process (Maybe DiedReason)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiedReason -> Maybe DiedReason
forall a. a -> Maybe a
Just
                   Delay
NoDelay  -> Int -> [Match DiedReason] -> Process (Maybe DiedReason)
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
0 (MonitorRef -> [Match DiedReason]
matches MonitorRef
mRef)
                   Delay TimeInterval
t  -> Int -> [Match DiedReason] -> Process (Maybe DiedReason)
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout (TimeInterval -> Int
asTimeout TimeInterval
t) (MonitorRef -> [Match DiedReason]
matches MonitorRef
mRef)
      -- let recv' =  if monitored then recv else withMonitor childPid' recv
      Maybe DiedReason
res <- Process (Maybe DiedReason)
recv Process (Maybe DiedReason)
-> Process () -> Process (Maybe DiedReason)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (MonitorRef -> Process ()
unmonitor MonitorRef
mRef)
      Process DiedReason -> Process b
restore' (Process DiedReason -> Process b)
-> Process DiedReason -> Process b
forall a b. (a -> b) -> a -> b
$ Process DiedReason
-> (DiedReason -> Process DiedReason)
-> Maybe DiedReason
-> Process DiedReason
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChildStopPolicy -> SupervisorPid -> State -> Process DiedReason
childShutdown ChildStopPolicy
StopImmediately SupervisorPid
childPid' State
state) DiedReason -> Process DiedReason
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DiedReason
res

    matches :: MonitorRef -> [Match DiedReason]
    matches :: MonitorRef -> [Match DiedReason]
matches MonitorRef
m = [
          (ProcessMonitorNotification -> ImmediateStart)
-> (ProcessMonitorNotification -> Process DiedReason)
-> Match DiedReason
forall a b.
Serializable a =>
(a -> ImmediateStart) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
m' SupervisorPid
_ DiedReason
_) -> MonitorRef
m MonitorRef -> MonitorRef -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== MonitorRef
m')
                  (\(ProcessMonitorNotification MonitorRef
_ SupervisorPid
_ DiedReason
r) -> DiedReason -> Process DiedReason
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return DiedReason
r)
        ]

--------------------------------------------------------------------------------
-- Loging/Reporting                                                          --
--------------------------------------------------------------------------------

errorMaxIntensityReached :: ExitReason
errorMaxIntensityReached :: ExitReason
errorMaxIntensityReached = ChildKey -> ExitReason
ExitOther ChildKey
"ReachedMaxRestartIntensity"

report :: MxSupervisor -> Process ()
report :: MxSupervisor -> Process ()
report = MxEvent -> Process ()
forall a. Serializable a => a -> Process ()
mxNotify (MxEvent -> Process ())
-> (MxSupervisor -> MxEvent) -> MxSupervisor -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> MxEvent
MxUser (Message -> MxEvent)
-> (MxSupervisor -> Message) -> MxSupervisor -> MxEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MxSupervisor -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage

{-logShutdown :: LogSink -> ChildKey -> ChildPid -> DiedReason -> Process ()-}
{-logShutdown log' child childPid reason = do-}
    {-sup <- getSelfPid-}
    {-Log.info log' $ mkReport banner sup (show childPid) shutdownReason-}
  {-where-}
    {-banner         = "Child Shutdown Complete"-}
    {-shutdownReason = (show reason) ++ ", child-key: " ++ child-}

logExit :: SupervisorPid -> ChildPid -> ExitReason -> Process ()
logExit :: SupervisorPid -> SupervisorPid -> ExitReason -> Process ()
logExit SupervisorPid
sup SupervisorPid
pid ExitReason
er = do
  MxSupervisor -> Process ()
report (MxSupervisor -> Process ()) -> MxSupervisor -> Process ()
forall a b. (a -> b) -> a -> b
$ SupervisorPid -> SupervisorPid -> ExitReason -> MxSupervisor
SupervisedChildDied SupervisorPid
sup SupervisorPid
pid ExitReason
er

logFailure :: SupervisorPid -> ChildPid -> SomeException -> Process ()
logFailure :: SupervisorPid -> SupervisorPid -> SomeException -> Process ()
logFailure SupervisorPid
sup SupervisorPid
childPid SomeException
ex = do
  (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
Log.notice (ChildKey -> Process ()) -> ChildKey -> Process ()
forall a b. (a -> b) -> a -> b
$ ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
"Detected Child Exit" SupervisorPid
sup (SupervisorPid -> ChildKey
forall a. Show a => a -> ChildKey
show SupervisorPid
childPid) (SomeException -> ChildKey
forall a. Show a => a -> ChildKey
show SomeException
ex)
  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
ex

logEntry :: (LogChan -> LogText -> Process ()) -> String -> Process ()
logEntry :: (LogChan -> ChildKey -> Process ()) -> ChildKey -> Process ()
logEntry LogChan -> ChildKey -> Process ()
lg = (LogChan -> ChildKey -> Process ())
-> LogChan -> ChildKey -> Process ()
forall l.
Logger l =>
(l -> ChildKey -> Process ()) -> l -> ChildKey -> Process ()
Log.report LogChan -> ChildKey -> Process ()
lg LogChan
Log.logChannel

mkReport :: String -> SupervisorPid -> String -> String -> String
mkReport :: ChildKey -> SupervisorPid -> ChildKey -> ShowS
mkReport ChildKey
b SupervisorPid
s ChildKey
c ChildKey
r = (ChildKey -> ShowS) -> ChildKey -> [ChildKey] -> ChildKey
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ChildKey
x ChildKey
xs -> ChildKey
xs ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
" " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
x) ChildKey
"" ([ChildKey] -> [ChildKey]
forall a. [a] -> [a]
reverse [ChildKey]
items)
  where
    items :: [String]
    items :: [ChildKey]
items = [ ChildKey
"[" ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
s' ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
"]" | ChildKey
s' <- [ ChildKey
b
                                       , ChildKey
"supervisor: " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ SupervisorPid -> ChildKey
forall a. Show a => a -> ChildKey
show SupervisorPid
s
                                       , ChildKey
"child: " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
c
                                       , ChildKey
"reason: " ChildKey -> ShowS
forall a. [a] -> [a] -> [a]
++ ChildKey
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 :: ImmediateStart
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildStopped ImmediateStart
ignored Child
child ChildSpecs
prefix ChildSpecs
remaining State
st =
  let spec :: ChildSpec
spec   = Child -> ChildSpec
forall a b. (a, b) -> b
snd Child
child
      rType :: RestartPolicy
rType  = ChildSpec -> RestartPolicy
childRestart ChildSpec
spec
      newRef :: ChildRef
newRef = if ImmediateStart
ignored then ChildRef
ChildStartIgnored else ChildRef
ChildStopped
  in case RestartPolicy -> ImmediateStart
isTemporary RestartPolicy
rType of
    ImmediateStart
True  -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$ (Accessor State ChildSpecs
specs Accessor State ChildSpecs -> ChildSpecs -> State -> State
forall r a. T r a -> a -> r -> r
^= ChildSpecs
prefix ChildSpecs -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a -> Seq a
>< ChildSpecs
remaining) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
st
    ImmediateStart
False -> State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$ (Accessor State ChildSpecs
specs Accessor State ChildSpecs -> ChildSpecs -> State -> State
forall r a. T r a -> a -> r -> r
^= ChildSpecs
prefix ChildSpecs -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a -> Seq a
>< ((ChildRef
newRef, ChildSpec
spec) Child -> ChildSpecs -> ChildSpecs
forall a. a -> Seq a -> Seq a
<| ChildSpecs
remaining)) State
st

setChildRestarting :: ChildPid -> Child -> Prefix -> Suffix -> State -> Maybe State
setChildRestarting :: SupervisorPid
-> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
setChildRestarting SupervisorPid
oldPid Child
child ChildSpecs
prefix ChildSpecs
remaining State
st =
  let spec :: ChildSpec
spec   = Child -> ChildSpec
forall a b. (a, b) -> b
snd Child
child
      newRef :: ChildRef
newRef = SupervisorPid -> ChildRef
ChildRestarting SupervisorPid
oldPid
  in State -> Maybe State
forall a. a -> Maybe a
Just (State -> Maybe State) -> State -> Maybe State
forall a b. (a -> b) -> a -> b
$ (Accessor State ChildSpecs
specs Accessor State ChildSpecs -> ChildSpecs -> State -> State
forall r a. T r a -> a -> r -> r
^= ChildSpecs
prefix ChildSpecs -> ChildSpecs -> ChildSpecs
forall a. Seq a -> Seq a -> Seq a
>< ((ChildRef
newRef, ChildSpec
spec) Child -> ChildSpecs -> ChildSpecs
forall a. a -> Seq a -> Seq a
<| ChildSpecs
remaining)) State
st

-- setChildStarted :: ChildPid ->

doAddChild :: AddChildReq -> Bool -> State -> AddChildRes
doAddChild :: AddChildReq -> ImmediateStart -> State -> AddChildRes
doAddChild (AddChild ImmediateStart
_ ChildSpec
spec) ImmediateStart
update State
st =
  let chType :: ChildType
chType = ChildSpec -> ChildType
childType ChildSpec
spec
  in case (ChildKey -> State -> Maybe Child
findChild (ChildSpec -> ChildKey
childKey ChildSpec
spec) State
st) of
       Just (ChildRef
ref, ChildSpec
_) -> ChildRef -> AddChildRes
Exists ChildRef
ref
       Maybe Child
Nothing ->
         case ImmediateStart
update of
           ImmediateStart
True  -> State -> AddChildRes
Added (State -> AddChildRes) -> State -> AddChildRes
forall a b. (a -> b) -> a -> b
$ ( (Accessor State ChildSpecs
specs Accessor State ChildSpecs
-> (ChildSpecs -> ChildSpecs) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: (ChildSpecs -> Child -> ChildSpecs
forall a. Seq a -> a -> Seq a
|> (ChildRef
ChildStopped, ChildSpec
spec)))
                           (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Specified ChildType
chType (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) State
st
                           )
           ImmediateStart
False -> State -> AddChildRes
Added State
st

updateChild :: ChildKey
            -> (Child -> Prefix -> Suffix -> State -> Maybe State)
            -> State
            -> Maybe State
updateChild :: ChildKey
-> (Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State)
-> State
-> Maybe State
updateChild ChildKey
key Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
updateFn State
state =
  let (ChildSpecs
prefix, ChildSpecs
suffix) = (Child -> ImmediateStart) -> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a. (a -> ImmediateStart) -> Seq a -> (Seq a, Seq a)
Seq.breakl ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildKey
key) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) (ChildSpecs -> (ChildSpecs, ChildSpecs))
-> ChildSpecs -> (ChildSpecs, ChildSpecs)
forall a b. (a -> b) -> a -> b
$ State
state State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs
  in case (ChildSpecs -> ViewL Child
forall a. Seq a -> ViewL a
Seq.viewl ChildSpecs
suffix) of
    ViewL Child
EmptyL             -> Maybe State
forall a. Maybe a
Nothing
    Child
child :< ChildSpecs
remaining -> Child -> ChildSpecs -> ChildSpecs -> State -> Maybe State
updateFn Child
child ChildSpecs
prefix ChildSpecs
remaining State
state

removeChild :: ChildSpec -> State -> State
removeChild :: ChildSpec -> State -> State
removeChild ChildSpec
spec State
state =
  let k :: ChildKey
k = ChildSpec -> ChildKey
childKey ChildSpec
spec
  in Accessor State ChildSpecs
specs Accessor State ChildSpecs
-> (ChildSpecs -> ChildSpecs) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: (Child -> ImmediateStart) -> ChildSpecs -> ChildSpecs
forall a. (a -> ImmediateStart) -> Seq a -> Seq a
filter ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
/= ChildKey
k) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state

-- DO NOT call this function unless you've verified the ChildRef first.
markActive :: State -> ChildRef -> ChildSpec -> State
markActive :: State -> ChildRef -> ChildSpec -> State
markActive State
state ChildRef
ref ChildSpec
spec =
  case ChildRef
ref of
    ChildRunning (SupervisorPid
pid :: ChildPid)  -> SupervisorPid -> State
inserted SupervisorPid
pid
    ChildRunningExtra SupervisorPid
pid Message
_         -> SupervisorPid -> State
inserted SupervisorPid
pid
    ChildRef
_                               -> ChildKey -> State
forall a. HasCallStack => ChildKey -> a
error (ChildKey -> State) -> ChildKey -> State
forall a b. (a -> b) -> a -> b
$ ChildKey
"InternalError"
  where
    inserted :: SupervisorPid -> State
inserted SupervisorPid
pid' = Accessor State (Map SupervisorPid ChildKey)
active Accessor State (Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> Map SupervisorPid ChildKey)
-> State
-> State
forall r a. T r a -> (a -> a) -> r -> r
^: SupervisorPid
-> ChildKey
-> Map SupervisorPid ChildKey
-> Map SupervisorPid ChildKey
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SupervisorPid
pid' (ChildSpec -> ChildKey
childKey ChildSpec
spec) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state

decrement :: Int -> Int
decrement :: Int -> Int
decrement Int
n = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: ChildKey -> State -> Maybe Child
findChild ChildKey
key State
st = (Child -> ImmediateStart) -> ChildSpecs -> Maybe Child
forall (t :: * -> *) a.
Foldable t =>
(a -> ImmediateStart) -> t a -> Maybe a
find ((ChildKey -> ChildKey -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== ChildKey
key) (ChildKey -> ImmediateStart)
-> (Child -> ChildKey) -> Child -> ImmediateStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildSpec -> ChildKey
childKey (ChildSpec -> ChildKey)
-> (Child -> ChildSpec) -> Child -> ChildKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Child -> ChildSpec
forall a b. (a, b) -> b
snd) (ChildSpecs -> Maybe Child) -> ChildSpecs -> Maybe Child
forall a b. (a -> b) -> a -> b
$ State
st State -> Accessor State ChildSpecs -> ChildSpecs
forall r a. r -> T r a -> a
^. Accessor State ChildSpecs
specs

bumpStats :: StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats :: StatsType -> ChildType -> (Int -> Int) -> State -> State
bumpStats StatsType
Specified ChildType
Supervisor Int -> Int
fn State
st = ((Int -> Int) -> State -> State
bump Int -> Int
fn) (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
supervisors Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
st
bumpStats StatsType
Specified ChildType
Worker     Int -> Int
fn State
st = ((Int -> Int) -> State -> State
bump Int -> Int
fn) (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
workers Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
st
bumpStats StatsType
Active    ChildType
Worker     Int -> Int
fn State
st = (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
running Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
activeWorkers Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
st
bumpStats StatsType
Active    ChildType
Supervisor Int -> Int
fn State
st = (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
running Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
activeSupervisors Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
fn) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
st

bump :: (Int -> Int) -> State -> State
bump :: (Int -> Int) -> State -> State
bump Int -> Int
with' = T State SupervisorStats
stats T State SupervisorStats
-> Accessor SupervisorStats Int -> Accessor State Int
forall a b c. Accessor a b -> Accessor b c -> Accessor a c
.> Accessor SupervisorStats Int
children Accessor State Int -> (Int -> Int) -> State -> State
forall r a. T r a -> (a -> a) -> r -> r
^: Int -> Int
with'

isTemporary :: RestartPolicy -> Bool
isTemporary :: RestartPolicy -> ImmediateStart
isTemporary = (RestartPolicy -> RestartPolicy -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== RestartPolicy
Temporary)

isTransient :: RestartPolicy -> Bool
isTransient :: RestartPolicy -> ImmediateStart
isTransient = (RestartPolicy -> RestartPolicy -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== RestartPolicy
Transient)

isIntrinsic :: RestartPolicy -> Bool
isIntrinsic :: RestartPolicy -> ImmediateStart
isIntrinsic = (RestartPolicy -> RestartPolicy -> ImmediateStart
forall a. Eq a => a -> a -> ImmediateStart
== RestartPolicy
Intrinsic)

active :: Accessor State (Map ChildPid ChildKey)
active :: Accessor State (Map SupervisorPid ChildKey)
active = (State -> Map SupervisorPid ChildKey)
-> (Map SupervisorPid ChildKey -> State -> State)
-> Accessor State (Map SupervisorPid ChildKey)
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> Map SupervisorPid ChildKey
_active (\Map SupervisorPid ChildKey
act' State
st -> State
st { _active = act' })

strategy :: Accessor State RestartStrategy
strategy :: Accessor State RestartStrategy
strategy = (State -> RestartStrategy)
-> (RestartStrategy -> State -> State)
-> Accessor State RestartStrategy
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> RestartStrategy
_strategy (\RestartStrategy
s State
st -> State
st { _strategy = s })

restartIntensity :: Accessor RestartStrategy RestartLimit
restartIntensity :: Accessor RestartStrategy RestartLimit
restartIntensity = (RestartStrategy -> RestartLimit)
-> (RestartLimit -> RestartStrategy -> RestartStrategy)
-> Accessor RestartStrategy RestartLimit
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor RestartStrategy -> RestartLimit
intensity (\RestartLimit
i RestartStrategy
l -> RestartStrategy
l { intensity = i })

-- | The "RestartLimit" for a given "RestartStrategy"
getRestartIntensity :: RestartStrategy -> RestartLimit
getRestartIntensity :: RestartStrategy -> RestartLimit
getRestartIntensity = (RestartStrategy
-> Accessor RestartStrategy RestartLimit -> RestartLimit
forall r a. r -> T r a -> a
^. Accessor RestartStrategy RestartLimit
restartIntensity)

restartPeriod :: Accessor State NominalDiffTime
restartPeriod :: Accessor State NominalDiffTime
restartPeriod = (State -> NominalDiffTime)
-> (NominalDiffTime -> State -> State)
-> Accessor State NominalDiffTime
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> NominalDiffTime
_restartPeriod (\NominalDiffTime
p State
st -> State
st { _restartPeriod = p })

restarts :: Accessor State [UTCTime]
restarts :: Accessor State [UTCTime]
restarts = (State -> [UTCTime])
-> ([UTCTime] -> State -> State) -> Accessor State [UTCTime]
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> [UTCTime]
_restarts (\[UTCTime]
r State
st -> State
st { _restarts = r })

specs :: Accessor State ChildSpecs
specs :: Accessor State ChildSpecs
specs = (State -> ChildSpecs)
-> (ChildSpecs -> State -> State) -> Accessor State ChildSpecs
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> ChildSpecs
_specs (\ChildSpecs
sp' State
st -> State
st { _specs = sp' })

stats :: Accessor State SupervisorStats
stats :: T State SupervisorStats
stats = (State -> SupervisorStats)
-> (SupervisorStats -> State -> State) -> T State SupervisorStats
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> SupervisorStats
_stats (\SupervisorStats
st' State
st -> State
st { _stats = st' })

logger :: Accessor State LogSink
logger :: Accessor State LogSink
logger = (State -> LogSink)
-> (LogSink -> State -> State) -> Accessor State LogSink
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor State -> LogSink
_logger (\LogSink
l State
st -> State
st { _logger = l })

children :: Accessor SupervisorStats Int
children :: Accessor SupervisorStats Int
children = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_children (\Int
c SupervisorStats
st -> SupervisorStats
st { _children = c })

-- | How many child specs are defined for this supervisor
definedChildren :: SupervisorStats -> Int
definedChildren :: SupervisorStats -> Int
definedChildren = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
children)

workers :: Accessor SupervisorStats Int
workers :: Accessor SupervisorStats Int
workers = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_workers (\Int
c SupervisorStats
st -> SupervisorStats
st { _workers = c })

-- | How many child specs define a worker (non-supervisor)
definedWorkers :: SupervisorStats -> Int
definedWorkers :: SupervisorStats -> Int
definedWorkers = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
workers)

supervisors :: Accessor SupervisorStats Int
supervisors :: Accessor SupervisorStats Int
supervisors = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_supervisors (\Int
c SupervisorStats
st -> SupervisorStats
st { _supervisors = c })

-- | How many child specs define a supervisor?
definedSupervisors :: SupervisorStats -> Int
definedSupervisors :: SupervisorStats -> Int
definedSupervisors = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
supervisors)

running :: Accessor SupervisorStats Int
running :: Accessor SupervisorStats Int
running = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_running (\Int
r SupervisorStats
st -> SupervisorStats
st { _running = r })

-- | How many running child processes.
runningChildren :: SupervisorStats -> Int
runningChildren :: SupervisorStats -> Int
runningChildren = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
running)

activeWorkers :: Accessor SupervisorStats Int
activeWorkers :: Accessor SupervisorStats Int
activeWorkers = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_activeWorkers (\Int
c SupervisorStats
st -> SupervisorStats
st { _activeWorkers = c })

-- | How many worker (non-supervisor) child processes are running.
runningWorkers :: SupervisorStats -> Int
runningWorkers :: SupervisorStats -> Int
runningWorkers = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
activeWorkers)

activeSupervisors :: Accessor SupervisorStats Int
activeSupervisors :: Accessor SupervisorStats Int
activeSupervisors = (SupervisorStats -> Int)
-> (Int -> SupervisorStats -> SupervisorStats)
-> Accessor SupervisorStats Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor SupervisorStats -> Int
_activeSupervisors (\Int
c SupervisorStats
st -> SupervisorStats
st { _activeSupervisors = c })

-- | How many supervisor child processes are running
runningSupervisors :: SupervisorStats -> Int
runningSupervisors :: SupervisorStats -> Int
runningSupervisors = (SupervisorStats -> Accessor SupervisorStats Int -> Int
forall r a. r -> T r a -> a
^. Accessor SupervisorStats Int
activeSupervisors)