{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Legion.Fork (
forkC,
forkL,
ForkM(..),
) where
import Control.Concurrent (forkIO)
import Control.Exception (SomeException)
import Control.Monad (void)
import Control.Monad.Catch (try, MonadCatch)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logError, askLoggerIO, runLoggingT,
MonadLoggerIO, LoggingT, MonadLoggerIO)
import Data.Text (pack)
import Network.Legion.LIO (LIO)
import System.Exit (ExitCode(ExitFailure))
import System.IO (hPutStrLn, stderr)
import System.Posix.Process (exitImmediately)
forkC :: (ForkM m, MonadCatch m, MonadLoggerIO m)
=> String
-> m ()
-> m ()
forkC name action =
forkM $ do
result <- try action
case result of
Left err -> do
let msg =
"Exception caught in critical thread " ++ show name
++ ". We are crashing the entire program because we can't "
++ "continue without this thread. The error was: "
++ show (err :: SomeException)
$(logError) . pack $ msg
liftIO (putStrLn msg)
liftIO (hPutStrLn stderr msg)
liftIO (exitImmediately (ExitFailure 1))
Right v -> return v
forkL :: (MonadLoggerIO io)
=> LIO ()
-> io ()
forkL io = liftIO . void . forkIO . runLoggingT io =<< askLoggerIO
class ForkM m where
forkM :: m () -> m ()
instance ForkM IO where
forkM = void . forkIO
instance ForkM (LoggingT IO) where
forkM action = do
logging <- askLoggerIO
liftIO . forkM $ runLoggingT action logging