SignalHandlers.hs

module Bein.Daemon.SignalHandlers (installSignalHandlers) where

import Database.HDBC ( fromSql, toSql )
import System.Exit ()
import System.Posix.Process ( ProcessStatus, getAnyProcessStatus )
import System.Posix.Process ()
import System.Posix.Signals
    ( installHandler,
      sigALRM,
      sigCHLD,
      sigHUP,
      sigPIPE,
      sigPROF,
      sigTERM,
      sigUSR1,
      sigUSR2,
      sigVTALRM,
      Handler(Ignore, Catch),
      fullSignalSet,
      deleteSignal )
import System.Posix.Syslog ( syslog, Priority(Notice) )
import System.Posix.Types ( ProcessID )
import System.Posix.Files ( fileExist )
import System.Directory ( removeDirectoryRecursive )
import Control.Monad.Trans ()
import Control.Monad.Reader
    ( when, MonadReader(ask), MonadIO(..), ReaderT(runReaderT) )
import Bein.Daemon.Commands
    ( exitDaemon, reconfigureDaemon, updateJobs, query, update )
import Bein.Daemon.Types ( BeinM, DaemonState )
  
installSignalHandlers :: BeinM DaemonState ()
installSignalHandlers = do
  st <- ask
  liftIO $ do
    installHandler sigALRM Ignore Nothing
    installHandler sigCHLD (Catch $ runReaderT (onDeadChildren cleanUpChild) st) (Just fullSignalSet)
    installHandler sigHUP (Catch $ runReaderT reconfigureDaemon st) Nothing
    installHandler sigPIPE Ignore Nothing
    installHandler sigPROF Ignore Nothing
    installHandler sigTERM (Catch $ runReaderT exitDaemon st) (Just $ deleteSignal sigCHLD fullSignalSet)
    installHandler sigUSR1 (Catch $ runReaderT updateJobs st) Nothing
    installHandler sigUSR2 Ignore Nothing
    installHandler sigVTALRM Ignore Nothing
  return ()
      
cleanUpChild :: ProcessID -> ProcessStatus -> BeinM DaemonState ()
cleanUpChild pid _ = do
  query "select id,status,scratch_dir from current_jobs where running_as_pid = ?" [toSql $ toInteger pid] >>= \r -> case r of
    [] -> liftIO $ syslog Notice ("Received SIGCHLD from unknown child with pid " ++ show pid)
    [[sId,_sStatus,sSD]] -> do liftIO $ ensureDeleted (fromSql sSD) 
                               update "delete from current_jobs where id = ?" [sId]
                               update "update executions set status='failed' where id = ? and status = 'running'" [sId]
    _ -> error "Invalid response from database.  Should have been unique."

ensureDeleted :: FilePath -> IO ()
ensureDeleted path = fileExist path >>= \b -> when b $ removeDirectoryRecursive path `catch` (const $ return ())  
                         
onDeadChildren :: (ProcessID -> ProcessStatus -> BeinM DaemonState ()) -> BeinM DaemonState ()
onDeadChildren act = do
  v <- liftIO $ getAnyProcessStatus False False
  case v of
    Just (pid,status) -> act pid status >> onDeadChildren act
    Nothing           -> return ()