{-# 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,
  )

--

-- | Make a non-zero exit code which is 0b1000000 + the number of the
-- signal. Probably never need this (especaially given our attempt to
-- write out a human readable name for the signal caught) but it's a
-- convention we're happy to observe.
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)

{-
    Technique to have a blocking MVar and signal handlers to set it
    adapted from code in vaultaire-common package's Vaultaire.Program,
    BSD3 licenced.
-}

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
Event -> 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
    )

--

-- | Install signal handlers for SIGINT and SIGTERM that set the exit
-- semaphore so that a Program's [minimal] cleanup can occur.
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 ()