module System.Posix.Graceful.Handler
( HandlerSettings(..)
, resetHandlers
, defaultHandlers
) where
import Control.Concurrent.STM ( atomically, TVar, newTVarIO, readTVar, modifyTVar' )
import Control.Monad ( void, unless )
import System.Exit ( ExitCode(..) )
import System.Posix.Process ( getAnyProcessStatus, exitImmediately )
import System.Posix.Signals ( Signal, signalProcess
, Handler(..), installHandler, fullSignalSet
, sigQUIT, sigHUP, sigINT, sigTERM, sigUSR2 )
import System.Posix.Types ( ProcessID )
data HandlerSettings =
HandlerSettings { handlerSettingsProcessIDs :: TVar [ProcessID]
, handlerSettingsQuitProcess :: IO ()
, handlerSettingsLaunchWorkers :: IO [ProcessID]
, handlerSettingsSpawnProcess :: IO ()
}
resetHandlers :: HandlerSettings -> IO ()
resetHandlers settings = do
void $ installHandler sigQUIT (CatchOnce $ handleSIGQUIT settings) (Just fullSignalSet)
void $ installHandler sigHUP (CatchOnce $ handleSIGHUP settings) (Just fullSignalSet)
void $ installHandler sigINT (CatchOnce $ handleSIGINT settings) (Just fullSignalSet)
void $ installHandler sigTERM (CatchOnce $ handleSIGTERM settings) (Just fullSignalSet)
void $ installHandler sigUSR2 (CatchOnce $ handleSIGUSR2 settings) (Just fullSignalSet)
defaultHandlers :: IO ()
defaultHandlers = do
void $ installHandler sigQUIT Default Nothing
void $ installHandler sigHUP Default Nothing
void $ installHandler sigINT Default Nothing
void $ installHandler sigTERM Default Nothing
void $ installHandler sigUSR2 Default Nothing
broadcastSignal :: HandlerSettings -> Signal -> IO ()
broadcastSignal settings s = do
pids <- atomically $ readTVar $ handlerSettingsProcessIDs settings
mapM_ (signalProcess s) pids
waitAllProcess :: HandlerSettings -> IO ()
waitAllProcess settings = do
status <- getAnyProcessStatus True False
case status of
Nothing -> return ()
Just (pid, _) -> do
remain <- atomically $ do
modifyTVar' (handlerSettingsProcessIDs settings) (filter (pid /=))
readTVar (handlerSettingsProcessIDs settings)
unless (null remain) $ waitAllProcess settings
shutdownGracefully :: HandlerSettings -> IO ()
shutdownGracefully settings = do
broadcastSignal settings sigQUIT
waitAllProcess settings
handleSIGINT :: HandlerSettings -> IO ()
handleSIGINT settings = do
broadcastSignal settings sigINT
waitAllProcess settings
exitImmediately $ ExitFailure 130
handleSIGTERM :: HandlerSettings -> IO ()
handleSIGTERM settings = do
broadcastSignal settings sigTERM
waitAllProcess settings
exitImmediately $ ExitFailure 143
handleSIGQUIT :: HandlerSettings -> IO ()
handleSIGQUIT settings = do
shutdownGracefully settings
handlerSettingsQuitProcess settings
handleSIGHUP :: HandlerSettings -> IO ()
handleSIGHUP settings = do
newpids <- handlerSettingsLaunchWorkers settings >>= newTVarIO
resetHandlers settings { handlerSettingsProcessIDs = newpids }
shutdownGracefully settings
handleSIGUSR2 :: HandlerSettings -> IO ()
handleSIGUSR2 settings = do
handlerSettingsSpawnProcess settings
resetHandlers settings