module Control.Concurrent.Capataz.Internal.Core
(
HasSupervisor(..)
, forkWorker
, forkSupervisor
, forkCapataz
, terminateProcess
, joinCapatazThread
, getSupervisorProcessId
, getSupervisorAsync
, getCapatazTeardown
)
where
import Protolude
import Control.Concurrent.MVar (newEmptyMVar, takeMVar)
import Control.Teardown (Teardown, newTeardown)
import Data.Time.Clock (getCurrentTime)
import qualified Data.UUID.V4 as UUID (nextRandom)
import qualified Control.Concurrent.Capataz.Internal.Supervisor as Supervisor
import Control.Concurrent.Capataz.Internal.Types
import qualified Control.Concurrent.Capataz.Internal.Util as Util
class HasSupervisor a where
getSupervisor :: a -> Supervisor
instance HasSupervisor Capataz where
getSupervisor Capataz {capatazSupervisor} = capatazSupervisor
instance HasSupervisor Supervisor where
getSupervisor = identity
forkCapataz :: Text -> (CapatazOptions -> CapatazOptions) -> IO Capataz
forkCapataz capatazName modOptionsFn = do
capatazId <- UUID.nextRandom
supervisorId <- UUID.nextRandom
let
capatazOptions@CapatazOptions { notifyEvent } =
defCapatazOptions capatazName modOptionsFn
supervisorOptions@SupervisorOptions { supervisorName } =
Util.capatazOptionsToSupervisorOptions capatazOptions
parentSupervisorEnv = ParentSupervisorEnv
{ supervisorId = capatazId
, supervisorName = "capataz-root"
, supervisorNotify = \supervisorEvent -> do
eventTime <- getCurrentTime
case supervisorEvent of
MonitorEvent ProcessFailed' { processError } -> notifyEvent
CapatazFailed
{ supervisorId
, supervisorName
, eventTime
, supervisorError = processError
}
MonitorEvent ProcessTerminated'{} -> notifyEvent CapatazTerminated
{ supervisorId
, supervisorName
, eventTime
}
MonitorEvent ProcessCompleted'{} ->
panic "Capataz completed; this should never happen"
MonitorEvent ProcessForcedRestart{} ->
panic
"Capataz was restarted from a OneForAll strategy; this should never happen"
ControlAction{} ->
panic "Capataz received a ControlAction message; bad implementation"
, notifyEvent
}
capatazSupervisor@Supervisor { supervisorEnv } <- Supervisor.supervisorMain
parentSupervisorEnv
supervisorOptions
supervisorId
0
capatazTeardown <- newTeardown
"capataz"
( do
Supervisor.haltSupervisor "capataz system shutdown" supervisorEnv
eventTime <- getCurrentTime
notifyEvent CapatazTerminated {supervisorId , supervisorName , eventTime }
)
return Capataz {capatazSupervisor , capatazTeardown }
forkWorker
:: HasSupervisor supervisor
=> WorkerOptions
-> supervisor
-> IO WorkerId
forkWorker workerOptions sup = do
let Supervisor { supervisorNotify } = getSupervisor sup
workerIdVar <- newEmptyMVar
supervisorNotify
( ControlAction ForkWorker
{ workerOptions
, returnWorkerId = putMVar workerIdVar
}
)
takeMVar workerIdVar
forkSupervisor
:: HasSupervisor parentSupervisor
=> SupervisorOptions
-> parentSupervisor
-> IO Supervisor
forkSupervisor supervisorOptions parentSup = do
let Supervisor { supervisorNotify } = getSupervisor parentSup
supervisorVar <- newEmptyMVar
supervisorNotify
( ControlAction ForkSupervisor
{ supervisorOptions
, returnSupervisor = putMVar supervisorVar
}
)
takeMVar supervisorVar
terminateProcess
:: HasSupervisor supervisor => Text -> ProcessId -> supervisor -> IO Bool
terminateProcess processTerminationReason processId supervisor = do
let Supervisor { supervisorNotify } = getSupervisor supervisor
result <- newEmptyMVar
supervisorNotify
( ControlAction TerminateProcess
{ processId
, processTerminationReason
, notifyProcessTermination = putMVar result
}
)
takeMVar result
joinCapatazThread :: Capataz -> IO ()
joinCapatazThread Capataz { capatazSupervisor } =
let Supervisor { supervisorAsync } = capatazSupervisor
in wait supervisorAsync
getCapatazTeardown :: Capataz -> Teardown
getCapatazTeardown Capataz { capatazTeardown } = capatazTeardown
getSupervisorAsync :: Supervisor -> Async ()
getSupervisorAsync Supervisor { supervisorAsync } = supervisorAsync
getSupervisorProcessId :: Supervisor -> ProcessId
getSupervisorProcessId Supervisor { supervisorId } = supervisorId