{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Concurrent.Capataz.Internal.Util where
import RIO
import qualified RIO.HashMap as HashMap
import qualified RIO.List as List
import qualified RIO.Text as T
import RIO.Time (getCurrentTime)
import GHC.Conc (labelThread)
import Control.Concurrent.Capataz.Internal.Types
getTidNumber :: ThreadId -> Maybe Text
getTidNumber tid = case T.words $ tshow tid of
(_ : tidNumber : _) -> Just tidNumber
_ -> Nothing
setProcessThreadName :: MonadIO m => WorkerId -> WorkerName -> m ()
setProcessThreadName workerId workerName = do
tid <- myThreadId
let workerIdentifier =
T.unpack workerName <> "_" <> show workerId <> "_" <> maybe
""
T.unpack
(getTidNumber tid)
liftIO $ labelThread tid workerIdentifier
getProcessId :: Process m -> ProcessId
getProcessId process = case process of
WorkerProcess Worker { workerId } -> workerId
SupervisorProcess Supervisor { supervisorId } -> supervisorId
fetchProcess
:: MonadIO m => SupervisorEnv m -> ProcessId -> m (Maybe (Process m))
fetchProcess SupervisorEnv { supervisorProcessMap } processId = do
processMap <- readIORef supervisorProcessMap
case HashMap.lookup processId processMap of
Just process -> return $ Just process
_ -> return Nothing
appendProcessToMap :: MonadIO m => SupervisorEnv m -> Process m -> m ()
appendProcessToMap SupervisorEnv { supervisorProcessMap } process =
atomicModifyIORef' supervisorProcessMap
(\processMap -> (appendProcess processMap, ()))
where
appendProcess = HashMap.alter (const $ Just process) (getProcessId process)
removeProcessFromMap :: MonadIO m => SupervisorEnv m -> ProcessId -> m ()
removeProcessFromMap SupervisorEnv { supervisorProcessMap } processId =
atomicModifyIORef'
supervisorProcessMap
(\processMap -> maybe (processMap, ())
(const (HashMap.delete processId processMap, ()))
(HashMap.lookup processId processMap)
)
resetProcessMap
:: MonadIO m => SupervisorEnv m -> (ProcessMap m -> ProcessMap m) -> m ()
resetProcessMap SupervisorEnv { supervisorProcessMap } processMapFn =
atomicModifyIORef' supervisorProcessMap
(\processMap -> (processMapFn processMap, ()))
readProcessMap :: MonadIO m => SupervisorEnv m -> m (ProcessMap m)
readProcessMap SupervisorEnv { supervisorProcessMap } =
readIORef supervisorProcessMap
sortProcessesByTerminationOrder
:: ProcessTerminationOrder -> ProcessMap m -> [Process m]
sortProcessesByTerminationOrder terminationOrder processMap =
case terminationOrder of
OldestFirst -> workers
NewestFirst -> reverse workers
where
processCreationTime (WorkerProcess Worker { workerCreationTime }) =
workerCreationTime
processCreationTime (SupervisorProcess Supervisor { supervisorCreationTime })
= supervisorCreationTime
workers =
List.sortBy (comparing processCreationTime) (HashMap.elems processMap)
readSupervisorStatusSTM :: TVar SupervisorStatus -> STM SupervisorStatus
readSupervisorStatusSTM statusVar = do
status <- readTVar statusVar
if status == Initializing then retrySTM else return status
readSupervisorStatus :: MonadIO m => SupervisorEnv m -> m SupervisorStatus
readSupervisorStatus SupervisorEnv { supervisorStatusVar } =
atomically $ readTVar supervisorStatusVar
writeSupervisorStatus
:: MonadIO m => SupervisorEnv m -> SupervisorStatus -> m ()
writeSupervisorStatus SupervisorEnv { supervisorId, supervisorName, supervisorStatusVar, notifyEvent } newSupervisorStatus
= do
prevSupervisorStatus <- atomically $ do
prevStatus <- readTVar supervisorStatusVar
writeTVar supervisorStatusVar newSupervisorStatus
return prevStatus
eventTime <- getCurrentTime
notifyEvent SupervisorStatusChanged
{ supervisorId = supervisorId
, supervisorName = supervisorName
, prevSupervisorStatus
, newSupervisorStatus
, eventTime
}
sendControlMsg :: SupervisorEnv m -> ControlAction m -> m ()
sendControlMsg SupervisorEnv { supervisorNotify } ctrlMsg =
supervisorNotify (ControlAction ctrlMsg)
sendSyncControlMsg
:: MonadIO m
=> SupervisorEnv m
-> (m () -> ControlAction m)
-> m ()
sendSyncControlMsg SupervisorEnv { supervisorNotify } mkCtrlMsg = do
result <- newEmptyMVar
supervisorNotify (ControlAction $ mkCtrlMsg (putMVar result ()))
takeMVar result
capatazOptionsToSupervisorOptions :: CapatazOptions m -> SupervisorOptions m
capatazOptionsToSupervisorOptions CapatazOptions {..} = SupervisorOptions {..}
toParentSupervisorEnv :: SupervisorEnv m -> ParentSupervisorEnv m
toParentSupervisorEnv SupervisorEnv { supervisorId, supervisorName, supervisorNotify, notifyEvent }
= ParentSupervisorEnv {..}