#include "HsUnixConfig.h"
module System.Posix.Signals (
Signal,
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,
pollableEvent, sigPOLL,
profilingTimerExpired, sigPROF,
badSystemCall, sigSYS,
breakpointTrap, sigTRAP,
urgentDataAvailable, sigURG,
virtualTimerExpired, sigVTALRM,
cpuTimeLimitExceeded, sigXCPU,
fileSizeLimitExceeded, sigXFSZ,
raiseSignal,
signalProcess,
signalProcessGroup,
Handler(Default,Ignore,Catch,CatchOnce),
installHandler,
SignalSet,
emptySignalSet, fullSignalSet, reservedSignals,
addSignal, deleteSignal, inSignalSet,
getSignalMask, setSignalMask, blockSignals, unblockSignals,
scheduleAlarm,
getPendingSignals,
awaitSignal,
setStoppedChildFlag, queryStoppedChildFlag,
) where
import Foreign hiding (unsafePerformIO)
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types
import System.Posix.Internals
import System.Posix.Process
import System.Posix.Process.Internals
import Data.Dynamic
#include "rts/Signals.h"
import GHC.Conc hiding (Signal)
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
pollableEvent :: Signal
pollableEvent = sigPOLL
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
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 :: 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 :: Signal -> IO ()
raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
foreign import ccall unsafe "raise"
c_raise :: CInt -> IO CInt
type Signal = CInt
data Handler = Default
| Ignore
| Catch (IO ())
| CatchOnce (IO ())
| CatchInfo (SignalInfo -> IO ())
| CatchInfoOnce (SignalInfo -> IO ())
deriving (Typeable)
data SignalInfo = SignalInfo {
siginfoSignal :: Signal,
siginfoError :: Errno,
siginfoSpecific :: SignalSpecificInfo
}
data SignalSpecificInfo
= NoSignalSpecificInfo
| SigChldInfo {
siginfoPid :: ProcessID,
siginfoUid :: UserID,
siginfoStatus :: ProcessStatus
}
installHandler :: Signal
-> Handler
-> Maybe SignalSet
-> IO Handler
installHandler sig handler _maybe_mask = do
ensureIOManagerIsRunning
(old_action, old_handler) <-
case handler of
Ignore -> do
old_action <- stg_sig_install sig STG_SIG_IGN nullPtr
old_handler <- setHandler sig Nothing
return (old_action, old_handler)
Default -> do
old_action <- stg_sig_install sig STG_SIG_DFL nullPtr
old_handler <- setHandler sig Nothing
return (old_action, old_handler)
_some_kind_of_catch -> do
let dyn = toDyn handler
old_handler <- case handler of
Catch action -> setHandler sig (Just (const action,dyn))
CatchOnce action -> setHandler sig (Just (const action,dyn))
CatchInfo action -> setHandler sig (Just (getinfo action,dyn))
CatchInfoOnce action -> setHandler sig (Just (getinfo action,dyn))
_ -> error "installHandler"
let action = case handler of
Catch _ -> STG_SIG_HAN
CatchOnce _ -> STG_SIG_RST
CatchInfo _ -> STG_SIG_HAN
CatchInfoOnce _ -> STG_SIG_RST
_ -> error "installHandler"
old_action <- stg_sig_install sig action nullPtr
return (old_action, old_handler)
case (old_handler,old_action) of
(_, STG_SIG_DFL) -> return $ Default
(_, STG_SIG_IGN) -> return $ Ignore
(Nothing, _) -> return $ Ignore
(Just (_,dyn), _)
| Just h <- fromDynamic dyn -> return h
| Just io <- fromDynamic dyn -> return (Catch io)
| otherwise -> return Default
foreign import ccall unsafe
stg_sig_install
:: CInt
-> CInt
-> Ptr CSigset
-> IO CInt
getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO ()
getinfo handler fp_info = do
si <- unmarshalSigInfo fp_info
handler si
unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo
unmarshalSigInfo fp = do
withForeignPtr fp $ \p -> do
sig <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
errno <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
extra <- case sig of
_ | sig == sigCHLD -> do
pid <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
uid <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p
wstat <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
pstat <- decipherWaitStatus wstat
return SigChldInfo { siginfoPid = pid,
siginfoUid = uid,
siginfoStatus = pstat }
_ | otherwise ->
return NoSignalSpecificInfo
return
SignalInfo {
siginfoSignal = sig,
siginfoError = Errno errno,
siginfoSpecific = extra }
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
foreign import ccall "&nocldstop" nocldstop :: Ptr Int
setStoppedChildFlag :: Bool -> IO Bool
setStoppedChildFlag b = do
rc <- peek nocldstop
poke nocldstop $ fromEnum (not b)
return (rc == (0::Int))
queryStoppedChildFlag :: IO Bool
queryStoppedChildFlag = do
rc <- peek nocldstop
return (rc == (0::Int))
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)
reservedSignals :: SignalSet
reservedSignals = addSignal rtsTimerSignal emptySignalSet
foreign import ccall rtsTimerSignal :: CInt
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 :: 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 :: SignalSet -> IO ()
setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
blockSignals :: SignalSet -> IO ()
blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
unblockSignals :: SignalSet -> IO ()
unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
getPendingSignals :: IO SignalSet
getPendingSignals = do
fp <- mallocForeignPtrBytes sizeof_sigset_t
withForeignPtr fp $ \p ->
throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
return (SignalSet fp)
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 ()
foreign import ccall unsafe "sigsuspend"
c_sigsuspend :: Ptr CSigset -> IO CInt
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
foreign import ccall unsafe "sigpending"
c_sigpending :: Ptr CSigset -> IO CInt