{-# 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 :: CInt -> ExitCode
code CInt
signal = Int -> ExitCode
ExitFailure (Int
128 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
signal)
interruptHandler :: MVar ExitCode -> Handler
interruptHandler :: MVar ExitCode -> Handler
interruptHandler MVar ExitCode
quit = IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stdout String
"\nInterrupt"
Handle -> IO ()
hFlush Handle
stdout
MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit (CInt -> ExitCode
code CInt
sigINT)
terminateHandler :: MVar ExitCode -> Handler
terminateHandler :: MVar ExitCode -> Handler
terminateHandler MVar ExitCode
quit = IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stdout String
"Terminating"
Handle -> IO ()
hFlush Handle
stdout
MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit (CInt -> ExitCode
code CInt
sigTERM)
logLevelHandler :: MVar Verbosity -> Handler
logLevelHandler :: MVar Verbosity -> Handler
logLevelHandler MVar Verbosity
v = IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stdout String
"Signal"
Handle -> IO ()
hFlush Handle
stdout
MVar Verbosity -> (Verbosity -> IO Verbosity) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Verbosity
v
( \Verbosity
level -> case Verbosity
level of
Verbosity
Output -> Verbosity -> IO Verbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Debug
Verbosity
Verbose -> Verbosity -> IO Verbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Debug
Verbosity
Debug -> Verbosity -> IO Verbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Output
)
setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO ()
setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO ()
setupSignalHandlers MVar ExitCode
quit MVar Verbosity
level = do
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigINT (MVar ExitCode -> Handler
interruptHandler MVar ExitCode
quit) Maybe SignalSet
forall a. Maybe a
Nothing
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigTERM (MVar ExitCode -> Handler
terminateHandler MVar ExitCode
quit) Maybe SignalSet
forall a. Maybe a
Nothing
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigUSR1 (MVar Verbosity -> Handler
logLevelHandler MVar Verbosity
level) Maybe SignalSet
forall a. Maybe a
Nothing
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()