{-# INCLUDE "HsUnixConfig.h" #-}
{-# INCLUDE <signal.h> #-}
{-# LINE 1 "System/Posix/Signals.hsc" #-}
-----------------------------------------------------------------------------
{-# LINE 2 "System/Posix/Signals.hsc" #-}
-- |
-- Module      :  System.Posix.Signals
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires POSIX)
--
-- POSIX signal support
--
-----------------------------------------------------------------------------


{-# LINE 16 "System/Posix/Signals.hsc" #-}
#include "HsUnixConfig.h"


{-# LINE 19 "System/Posix/Signals.hsc" #-}

{-# LINE 20 "System/Posix/Signals.hsc" #-}

{-# LINE 21 "System/Posix/Signals.hsc" #-}

module System.Posix.Signals (
  -- * The Signal type
  Signal,

  -- * Specific signals
  nullSignal,
  internalAbort, sigABRT,
  realTimeAlarm, sigALRM,
  busError, sigBUS,
  processStatusChanged, sigCHLD,
  continueProcess, sigCONT,
  floatingPointException, sigFPE,
  lostConnection, sigHUP,
  illegalInstruction, sigILL,
  keyboardSignal, sigINT,
  killProcess, sigKILL,
  openEndedPipe, sigPIPE,
  keyboardTermination, sigQUIT,
  segmentationViolation, sigSEGV,
  softwareStop, sigSTOP,
  softwareTermination, sigTERM,
  keyboardStop, sigTSTP,
  backgroundRead, sigTTIN,
  backgroundWrite, sigTTOU,
  userDefinedSignal1, sigUSR1,
  userDefinedSignal2, sigUSR2,

{-# LINE 49 "System/Posix/Signals.hsc" #-}
  pollableEvent, sigPOLL,

{-# LINE 51 "System/Posix/Signals.hsc" #-}
  profilingTimerExpired, sigPROF,
  badSystemCall, sigSYS,
  breakpointTrap, sigTRAP,
  urgentDataAvailable, sigURG,
  virtualTimerExpired, sigVTALRM,
  cpuTimeLimitExceeded, sigXCPU,
  fileSizeLimitExceeded, sigXFSZ,

  -- * Sending signals
  raiseSignal,
  signalProcess,
  signalProcessGroup,


{-# LINE 65 "System/Posix/Signals.hsc" #-}
  -- * Handling signals
  addSignalHandler, addOneShotSignalHandler, removeSignalHandler,
  SignalHandler, SignalInfo(..), SignalSpecificInfo(..),

  -- * (old, deprecated) Handling signals
  Handler(..),  installHandler,

{-# LINE 72 "System/Posix/Signals.hsc" #-}

  -- * Signal sets
  SignalSet,
  emptySignalSet, fullSignalSet, 
  addSignal, deleteSignal, inSignalSet,

  -- * The process signal mask
  getSignalMask, setSignalMask, blockSignals, unblockSignals,

  -- * The alarm timer
  scheduleAlarm,

  -- * Waiting for signals
  getPendingSignals,

{-# LINE 87 "System/Posix/Signals.hsc" #-}
  awaitSignal,

{-# LINE 89 "System/Posix/Signals.hsc" #-}


{-# LINE 91 "System/Posix/Signals.hsc" #-}
  -- * The @NOCLDSTOP@ flag
  setStoppedChildFlag, queryStoppedChildFlag,

{-# LINE 94 "System/Posix/Signals.hsc" #-}

  -- MISSING FUNCTIONALITY:
  -- sigaction(), (inc. the sigaction structure + flags etc.)
  -- the siginfo structure
  -- sigaltstack()
  -- sighold, sigignore, sigpause, sigrelse, sigset
  -- siginterrupt
  ) where

import Foreign
import Foreign.C
import System.IO.Unsafe
import System.Posix.Types
import System.Posix.Internals
import System.Posix.Process.Internals
import System.Posix.Process
import Control.Concurrent
import Control.Exception (bracket)
import Data.List (partition)
import Control.Monad


{-# LINE 116 "System/Posix/Signals.hsc" #-}
#include "Signals.h"
import qualified GHC.Conc
import GHC.Conc hiding (Handler)

{-# LINE 120 "System/Posix/Signals.hsc" #-}

-- -----------------------------------------------------------------------------
-- Specific signals

nullSignal :: Signal
nullSignal = 0

sigABRT   :: CInt
sigABRT   = CONST_SIGABRT
sigALRM   :: CInt
sigALRM   = CONST_SIGALRM
sigBUS    :: CInt
sigBUS    = CONST_SIGBUS
sigCHLD   :: CInt
sigCHLD   = CONST_SIGCHLD
sigCONT   :: CInt
sigCONT   = CONST_SIGCONT
sigFPE    :: CInt
sigFPE    = CONST_SIGFPE
sigHUP    :: CInt
sigHUP    = CONST_SIGHUP
sigILL    :: CInt
sigILL    = CONST_SIGILL
sigINT    :: CInt
sigINT    = CONST_SIGINT
sigKILL   :: CInt
sigKILL   = CONST_SIGKILL
sigPIPE   :: CInt
sigPIPE   = CONST_SIGPIPE
sigQUIT   :: CInt
sigQUIT   = CONST_SIGQUIT
sigSEGV   :: CInt
sigSEGV   = CONST_SIGSEGV
sigSTOP   :: CInt
sigSTOP   = CONST_SIGSTOP
sigTERM   :: CInt
sigTERM   = CONST_SIGTERM
sigTSTP   :: CInt
sigTSTP   = CONST_SIGTSTP
sigTTIN   :: CInt
sigTTIN   = CONST_SIGTTIN
sigTTOU   :: CInt
sigTTOU   = CONST_SIGTTOU
sigUSR1   :: CInt
sigUSR1   = CONST_SIGUSR1
sigUSR2   :: CInt
sigUSR2   = CONST_SIGUSR2
sigPOLL   :: CInt
sigPOLL   = CONST_SIGPOLL
sigPROF   :: CInt
sigPROF   = CONST_SIGPROF
sigSYS    :: CInt
sigSYS    = CONST_SIGSYS
sigTRAP   :: CInt
sigTRAP   = CONST_SIGTRAP
sigURG    :: CInt
sigURG    = CONST_SIGURG
sigVTALRM :: CInt
sigVTALRM = CONST_SIGVTALRM
sigXCPU   :: CInt
sigXCPU   = CONST_SIGXCPU
sigXFSZ   :: CInt
sigXFSZ   = CONST_SIGXFSZ

internalAbort ::Signal
internalAbort = sigABRT

realTimeAlarm :: Signal
realTimeAlarm = sigALRM

busError :: Signal
busError = sigBUS

processStatusChanged :: Signal
processStatusChanged = sigCHLD

continueProcess :: Signal
continueProcess = sigCONT

floatingPointException :: Signal
floatingPointException = sigFPE

lostConnection :: Signal
lostConnection = sigHUP

illegalInstruction :: Signal
illegalInstruction = sigILL

keyboardSignal :: Signal
keyboardSignal = sigINT

killProcess :: Signal
killProcess = sigKILL

openEndedPipe :: Signal
openEndedPipe = sigPIPE

keyboardTermination :: Signal
keyboardTermination = sigQUIT

segmentationViolation :: Signal
segmentationViolation = sigSEGV

softwareStop :: Signal
softwareStop = sigSTOP

softwareTermination :: Signal
softwareTermination = sigTERM

keyboardStop :: Signal
keyboardStop = sigTSTP

backgroundRead :: Signal
backgroundRead = sigTTIN

backgroundWrite :: Signal
backgroundWrite = sigTTOU

userDefinedSignal1 :: Signal
userDefinedSignal1 = sigUSR1

userDefinedSignal2 :: Signal
userDefinedSignal2 = sigUSR2


{-# LINE 245 "System/Posix/Signals.hsc" #-}
pollableEvent :: Signal
pollableEvent = sigPOLL

{-# LINE 248 "System/Posix/Signals.hsc" #-}

profilingTimerExpired :: Signal
profilingTimerExpired = sigPROF

badSystemCall :: Signal
badSystemCall = sigSYS

breakpointTrap :: Signal
breakpointTrap = sigTRAP

urgentDataAvailable :: Signal
urgentDataAvailable = sigURG

virtualTimerExpired :: Signal
virtualTimerExpired = sigVTALRM

cpuTimeLimitExceeded :: Signal
cpuTimeLimitExceeded = sigXCPU

fileSizeLimitExceeded :: Signal
fileSizeLimitExceeded = sigXFSZ

-- -----------------------------------------------------------------------------
-- Signal-related functions

-- | @signalProcess int pid@ calls @kill@ to signal process @pid@ 
--   with interrupt signal @int@.
signalProcess :: Signal -> ProcessID -> IO ()
signalProcess sig pid 
 = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)

foreign import ccall unsafe "kill"
  c_kill :: CPid -> CInt -> IO CInt


-- | @signalProcessGroup int pgid@ calls @kill@ to signal 
--  all processes in group @pgid@ with interrupt signal @int@.
signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
signalProcessGroup sig pgid 
  = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)

foreign import ccall unsafe "killpg"
  c_killpg :: CPid -> CInt -> IO CInt

-- | @raiseSignal int@ calls @kill@ to signal the current process
--   with interrupt signal @int@. 
raiseSignal :: Signal -> IO ()
raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)


{-# LINE 301 "System/Posix/Signals.hsc" #-}
foreign import ccall unsafe "raise"
  c_raise :: CInt -> IO CInt

{-# LINE 304 "System/Posix/Signals.hsc" #-}


{-# LINE 306 "System/Posix/Signals.hsc" #-}
data Handler = Default
             | Ignore
	     -- not yet: | Hold 
             | Catch (IO ())
             | CatchOnce (IO ())

-- | @installHandler int handler iset@ calls @sigaction@ to install an
--   interrupt handler for signal @int@.  If @handler@ is @Default@,
--   @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
--   installed; if @handler@ is @Catch action@, a handler is installed
--   which will invoke @action@ in a new thread when (or shortly after) the
--   signal is received.
--   If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
--   is set to @s@; otherwise it is cleared.  The previously installed
--   signal handler for @int@ is returned
{- DEPRECATED installHandler "use addSignalHandler instead" #-}
installHandler :: Signal
               -> Handler
               -> Maybe SignalSet	-- ^ other signals to block
               -> IO Handler		-- ^ old handler


{-# LINE 331 "System/Posix/Signals.hsc" #-}

installHandler sig handler maybe_mask = do
  old <- remove_old_handler
  case handler of
    Default          -> return ()
    Ignore           -> add_handler sig (return ()) addSignalHandler
    Catch action     -> add_handler sig action addSignalHandler
    CatchOnce action -> add_handler sig action addOneShotSignalHandler
  return old
  where
    remove_old_handler = do
       modifyMVar old_handler_ref $ \old_handlers -> do
         let (this, others) = partition ((== sig) . fst3) old_handlers
             fst3 (x,_,_) = x
         case this of
            [] -> return (others, Default)
            ((t,id,h):_) -> do
                removeSignalHandler sig id
                return (others, h)

    add_handler sig action add = do
       id <- add sig (const action)
       modifyMVar_ old_handler_ref $ \xs ->
         return ((sig, id, Catch action) : xs)

old_handler_ref :: MVar [(Signal, HandlerId, Handler)]
old_handler_ref = unsafePerformIO (newMVar [])


{-# LINE 360 "System/Posix/Signals.hsc" #-}

{-# LINE 361 "System/Posix/Signals.hsc" #-}

-- -----------------------------------------------------------------------------
-- New signal-handling API

data SignalState = SignalDefault | SignalHandled

setSignalState :: Signal -> SignalState -> IO SignalState
setSignalState sig state = do
  ensureIOManagerIsRunning  -- for the threaded RTS
  r <- stg_sig_install sig (fromState state) nullPtr
  if (r == STG_SIG_ERR)
    then throwErrno "setSignalState"
    else return (toState r)
  where
    fromState SignalDefault = STG_SIG_DFL
    fromState SignalHandled = STG_SIG_HAN

    toState STG_SIG_DFL = SignalDefault
    toState STG_SIG_HAN = SignalHandled

foreign import ccall unsafe
  stg_sig_install
	:: CInt				-- sig no.
	-> CInt				-- action code (STG_SIG_HAN etc.)
	-> Ptr CSigset			-- (in, out) blocked
	-> IO CInt			-- (ret) old action code

type SignalHandler = SignalInfo -> IO ()

-- | registers a signal handler function to be executed when the specified
-- signal is received.  Any number of signal handler functions may be attached
-- to a signal using 'addSignalHandler'.
--
-- When a signal is received, each handler registered for the signal
-- is forked in a new thread.
--
-- While there are any signal handlers registered for a given signal,
-- the default behaviour of that signal is disabled.  The default
-- behaviour for some signals is to terminate or stop the process
-- (consult the POSIX documentation or the @signal@ man-page for a
-- list), while for others the default behaviour is to ignore the
-- signal.  To explicitly ignore a signal for which the default
-- behaviour is to terminate the process, use
--
-- > addSignalHandler sig (const (return ()))
--
addSignalHandler :: Signal -> SignalHandler -> IO HandlerId
addSignalHandler sig handler = do
  setSignalState sig SignalHandled
  GHC.Conc.addHandler sig (getinfo handler) False

-- | like 'addSignalHandler' except the signal handler is run at most once,
-- the next time the signal is received.
--
addOneShotSignalHandler :: Signal -> SignalHandler -> IO HandlerId
addOneShotSignalHandler sig handler = do
  setSignalState sig SignalHandled
  GHC.Conc.addHandler sig (getinfo handler) True

getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO ()
getinfo handler fp_info = do
  si <- unmarshalSigInfo fp_info
  handler si

-- | remove the specified signal handler.  Returns 'True' if the
-- signal handler was found and successfully removed, or 'False' if
-- the specified signal handler could not be found.
--
removeSignalHandler :: Signal -> HandlerId -> IO Bool
removeSignalHandler sig id = do
  r <- GHC.Conc.removeHandler sig id
  none <- noHandlers sig
  when none $ do setSignalState sig SignalDefault; return ()
  return r

unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo
unmarshalSigInfo fp = do
  withForeignPtr fp $ \p -> do
    sig   <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 440 "System/Posix/Signals.hsc" #-}
    errno <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
{-# LINE 441 "System/Posix/Signals.hsc" #-}
    extra <- case sig of
                _ | sig == sigCHLD -> do
                    pid <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 444 "System/Posix/Signals.hsc" #-}
                    uid <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p
{-# LINE 445 "System/Posix/Signals.hsc" #-}
                    wstat <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
{-# LINE 446 "System/Posix/Signals.hsc" #-}
                    pstat <- decipherWaitStatus wstat
                    return SigChldInfo { siginfoPid = pid,
                                         siginfoUid = uid,
                                         siginfoStatus = pstat }
                _ | otherwise ->
                    return NoSignalSpecificInfo
    return
      SignalInfo {
        siginfoSignal = sig,
        siginfoError  = Errno errno,
        siginfoSpecific = extra }

-- | Information about a received signal (derived from @siginfo_t@).
data SignalInfo = SignalInfo {
      siginfoSignal   :: Signal,
      siginfoError    :: Errno,
      siginfoSpecific :: SignalSpecificInfo
  }

-- | Information specific to a particular type of signal
-- (derived from @siginfo_t@).
data SignalSpecificInfo
  = NoSignalSpecificInfo
  | SigChldInfo {
      siginfoPid    :: ProcessID,
      siginfoUid    :: UserID,
      siginfoStatus :: ProcessStatus
    }

-- -----------------------------------------------------------------------------
-- Alarms

-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
--   alarm at least @i@ seconds in the future.
scheduleAlarm :: Int -> IO Int
scheduleAlarm secs = do
   r <- c_alarm (fromIntegral secs)
   return (fromIntegral r)

foreign import ccall unsafe "alarm"
  c_alarm :: CUInt -> IO CUInt


{-# LINE 489 "System/Posix/Signals.hsc" #-}
-- -----------------------------------------------------------------------------
-- The NOCLDSTOP flag

foreign import ccall "&nocldstop" nocldstop :: Ptr Int

-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
-- installing new signal handlers.
setStoppedChildFlag :: Bool -> IO Bool
setStoppedChildFlag b = do
    rc <- peek nocldstop
    poke nocldstop $ fromEnum (not b) 
    return (rc == (0::Int))

-- | Queries the current state of the stopped child flag.
queryStoppedChildFlag :: IO Bool
queryStoppedChildFlag = do
    rc <- peek nocldstop
    return (rc == (0::Int))

{-# LINE 508 "System/Posix/Signals.hsc" #-}

-- -----------------------------------------------------------------------------
-- Manipulating signal sets

newtype SignalSet = SignalSet (ForeignPtr CSigset)

emptySignalSet :: SignalSet
emptySignalSet = unsafePerformIO $ do
  fp <- mallocForeignPtrBytes sizeof_sigset_t
  throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
  return (SignalSet fp)

fullSignalSet :: SignalSet
fullSignalSet = unsafePerformIO $ do
  fp <- mallocForeignPtrBytes sizeof_sigset_t
  throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
  return (SignalSet fp)

infixr `addSignal`, `deleteSignal`
addSignal :: Signal -> SignalSet -> SignalSet
addSignal sig (SignalSet fp1) = unsafePerformIO $ do
  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
  withForeignPtr fp1 $ \p1 ->
    withForeignPtr fp2 $ \p2 -> do
      copyBytes p2 p1 sizeof_sigset_t
      throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
  return (SignalSet fp2)

deleteSignal :: Signal -> SignalSet -> SignalSet
deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
  withForeignPtr fp1 $ \p1 ->
    withForeignPtr fp2 $ \p2 -> do
      copyBytes p2 p1 sizeof_sigset_t
      throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
  return (SignalSet fp2)

inSignalSet :: Signal -> SignalSet -> Bool
inSignalSet sig (SignalSet fp) = unsafePerformIO $
  withForeignPtr fp $ \p -> do
    r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
    return (r /= 0)

-- | @getSignalMask@ calls @sigprocmask@ to determine the
--   set of interrupts which are currently being blocked.
getSignalMask :: IO SignalSet
getSignalMask = do
  fp <- mallocForeignPtrBytes sizeof_sigset_t
  withForeignPtr fp $ \p ->
    throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
  return (SignalSet fp)
   
sigProcMask :: String -> CInt -> SignalSet -> IO ()
sigProcMask fn how (SignalSet set) =
  withForeignPtr set $ \p_set ->
    throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)

-- | @setSignalMask mask@ calls @sigprocmask@ with
--   @SIG_SETMASK@ to block all interrupts in @mask@.
setSignalMask :: SignalSet -> IO ()
setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set

-- | @blockSignals mask@ calls @sigprocmask@ with
--   @SIG_BLOCK@ to add all interrupts in @mask@ to the
--  set of blocked interrupts.
--
-- Note: this is not particularly useful in Haskell, signal handlers
-- are not atomic as they are in C.  A signal handler may have already
-- been created as a thread, but not run yet, and `blockSignals` will
-- not prevent it from running.  You should consider other methods for
-- synchronising with signal handlers, such as MVars or STM.
blockSignals :: SignalSet -> IO ()
blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set

-- | @unblockSignals mask@ calls @sigprocmask@ with
--   @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
--   set of blocked interrupts. 
unblockSignals :: SignalSet -> IO ()
unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set

-- | @getPendingSignals@ calls @sigpending@ to obtain
--   the set of interrupts which have been received but are currently blocked.
getPendingSignals :: IO SignalSet
getPendingSignals = do
  fp <- mallocForeignPtrBytes sizeof_sigset_t
  withForeignPtr fp $ \p -> 
   throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
  return (SignalSet fp)


{-# LINE 598 "System/Posix/Signals.hsc" #-}

-- | @awaitSignal iset@ suspends execution until an interrupt is received.
-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
-- @s@ as the new signal mask before suspending execution; otherwise, it
-- calls @pause@.  @awaitSignal@ returns on receipt of a signal.  If you
-- have installed any signal handlers with @handleSignal@, for example, it may be
-- wise to call @yield@ directly after @awaitSignal@ to ensure that the
-- signal handler runs as promptly as possible.
awaitSignal :: Maybe SignalSet -> IO ()
awaitSignal maybe_sigset = do
  fp <- case maybe_sigset of
    	  Nothing -> do SignalSet fp <- getSignalMask; return fp
    	  Just (SignalSet fp) -> return fp
  withForeignPtr fp $ \p -> do
  c_sigsuspend p
  return ()
  -- ignore the return value; according to the docs it can only ever be
  -- (-1) with errno set to EINTR.
 
foreign import ccall unsafe "sigsuspend"
  c_sigsuspend :: Ptr CSigset -> IO CInt

{-# LINE 620 "System/Posix/Signals.hsc" #-}


{-# LINE 631 "System/Posix/Signals.hsc" #-}
foreign import ccall unsafe "__hscore_sigdelset"
  c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_sigfillset"
  c_sigfillset  :: Ptr CSigset -> IO CInt

foreign import ccall unsafe "__hscore_sigismember"
  c_sigismember :: Ptr CSigset -> CInt -> IO CInt

{-# LINE 640 "System/Posix/Signals.hsc" #-}

foreign import ccall unsafe "sigpending"
  c_sigpending :: Ptr CSigset -> IO CInt