{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Core.Program.Signal
( setupSignalHandlers,
)
where
import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar)
import Core.Program.Context
import Foreign.C.Types (CInt)
import System.Exit (ExitCode (..))
import System.IO (hFlush, hPutStrLn, stdout)
import System.Posix.Signals
( Handler (Catch),
installHandler,
sigINT,
sigTERM,
sigUSR1,
)
code :: CInt -> ExitCode
code signal = ExitFailure (128 + fromIntegral signal)
interruptHandler :: MVar ExitCode -> Handler
interruptHandler quit = Catch $ do
hPutStrLn stdout "\nInterrupt"
hFlush stdout
putMVar quit (code sigINT)
terminateHandler :: MVar ExitCode -> Handler
terminateHandler quit = Catch $ do
hPutStrLn stdout "Terminating"
hFlush stdout
putMVar quit (code sigTERM)
logLevelHandler :: MVar Verbosity -> Handler
logLevelHandler v = Catch $ do
hPutStrLn stdout "Signal"
hFlush stdout
modifyMVar_
v
( \level -> case level of
Output -> pure Debug
Event -> pure Debug
Debug -> pure Output
)
setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO ()
setupSignalHandlers quit level = do
installHandler sigINT (interruptHandler quit) Nothing
installHandler sigTERM (terminateHandler quit) Nothing
installHandler sigUSR1 (logLevelHandler level) Nothing
return ()