{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Control.Concurrent.Capataz.Internal.Core
(
HasSupervisor(..)
, forkWorker
, forkSupervisor
, forkCapataz
, terminateProcess
, terminateCapataz
, terminateCapataz_
, joinCapatazThread
, getSupervisorProcessId
, getSupervisorAsync
, getCapatazTeardown
)
where
import RIO
import Control.Teardown (Teardown, TeardownResult, newTeardown, runTeardown, runTeardown_)
import RIO.Time (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 m -> Supervisor m
instance HasSupervisor Capataz where
getSupervisor Capataz {capatazSupervisor} = capatazSupervisor
instance HasSupervisor Supervisor where
getSupervisor = id
forkCapataz
:: (MonadUnliftIO m, MonadIO m)
=> Text
-> (CapatazOptions m -> CapatazOptions m)
-> m (Capataz m)
forkCapataz capatazName modOptionsFn = do
capatazId <- liftIO UUID.nextRandom
supervisorId <- liftIO 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'{} ->
error "Capataz completed; this should never happen"
MonitorEvent ProcessForcedRestart{} ->
error
"Capataz was restarted from a OneForAll strategy; this should never happen"
ControlAction{} ->
error "Capataz received a ControlAction message; bad implementation"
, notifyEvent
}
capatazSupervisor@Supervisor { supervisorEnv } <- Supervisor.supervisorMain
parentSupervisorEnv
supervisorOptions
supervisorId
0
capatazTeardown <- withRunInIO $ \run -> newTeardown
"capataz"
(run $ do
Supervisor.haltSupervisor "capataz system shutdown" supervisorEnv
eventTime <- getCurrentTime
notifyEvent CapatazTerminated {supervisorId , supervisorName , eventTime }
)
return Capataz {capatazSupervisor , capatazTeardown }
forkWorker
:: (MonadIO m, HasSupervisor supervisor)
=> WorkerOptions m
-> supervisor m
-> m WorkerId
forkWorker workerOptions sup = do
let Supervisor { supervisorNotify } = getSupervisor sup
workerIdVar <- newEmptyMVar
supervisorNotify
(ControlAction ForkWorker
{ workerOptions
, returnWorkerId = putMVar workerIdVar
}
)
takeMVar workerIdVar
forkSupervisor
:: (MonadIO m, HasSupervisor parentSupervisor)
=> SupervisorOptions m
-> parentSupervisor m
-> m (Supervisor m)
forkSupervisor supervisorOptions parentSup = do
let Supervisor { supervisorNotify } = getSupervisor parentSup
supervisorVar <- newEmptyMVar
supervisorNotify
(ControlAction ForkSupervisor
{ supervisorOptions
, returnSupervisor = putMVar supervisorVar
}
)
takeMVar supervisorVar
terminateProcess
:: (MonadIO m, HasSupervisor supervisor)
=> Text
-> ProcessId
-> supervisor m
-> m Bool
terminateProcess processTerminationReason processId supervisor = do
let Supervisor { supervisorNotify } = getSupervisor supervisor
result <- newEmptyMVar
supervisorNotify
(ControlAction TerminateProcess
{ processId
, processTerminationReason
, notifyProcessTermination = putMVar result
}
)
takeMVar result
joinCapatazThread :: MonadIO m => Capataz m -> m ()
joinCapatazThread Capataz { capatazSupervisor } =
let Supervisor { supervisorAsync } = capatazSupervisor
in wait supervisorAsync
terminateCapataz :: MonadIO m => Capataz m -> m TeardownResult
terminateCapataz = liftIO . runTeardown
terminateCapataz_ :: MonadIO m => Capataz m -> m ()
terminateCapataz_ = liftIO . runTeardown_
getCapatazTeardown :: Capataz m -> Teardown
getCapatazTeardown Capataz { capatazTeardown } = capatazTeardown
getSupervisorAsync :: Supervisor m -> Async ()
getSupervisorAsync Supervisor { supervisorAsync } = supervisorAsync
getSupervisorProcessId :: Supervisor m -> ProcessId
getSupervisorProcessId Supervisor { supervisorId } = supervisorId