%
% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
%
\section[PosixProcPrim]{Haskell 1.3 POSIX Process Primitives}

\begin{code}
{-# OPTIONS -#include "HsPosix.h" #-}

#include "config.h"

module PosixProcPrim (
    Handler(..),
    SignalSet,
    Signal,
    ProcessStatus(..),

    addSignal,
#ifndef cygwin32_TARGET_OS
    awaitSignal,
#endif
    backgroundRead,
    backgroundWrite,
    blockSignals,
#ifndef cygwin32_TARGET_OS
    continueProcess,
#endif
    deleteSignal,
    emptySignalSet,
    executeFile,
    exitImmediately,
    floatingPointException,
    forkProcess,
    fullSignalSet,
    getAnyProcessStatus,
    getEnvVar,
    getEnvironment,
    getGroupProcessStatus,
    getPendingSignals,
    getProcessStatus,
    getSignalMask,
    illegalInstruction,
    inSignalSet,
    installHandler,
    internalAbort,
    keyboardSignal,
    keyboardStop,
    keyboardTermination,
    killProcess,
    lostConnection,
    nullSignal,
    openEndedPipe,
    processStatusChanged,
    queryStoppedChildFlag,
    raiseSignal,
    realTimeAlarm,
    removeEnvVar,
    scheduleAlarm,
    segmentationViolation,
    setEnvVar,
    setEnvironment,
    setSignalMask,
    setStoppedChildFlag,
    sigABRT,
    sigALRM,
    sigCHLD,
#ifndef cygwin32_TARGET_OS
    sigCONT,
#endif
    sigFPE,
    sigHUP,
    sigILL,
    sigINT,
    sigKILL,
    sigPIPE,
    sigProcMask,
    sigQUIT,
    sigSEGV,
    sigSTOP,
    sigSetSize,
    sigTERM,
    sigTSTP,
    sigTTIN,
    sigTTOU,
    sigUSR1,
    sigUSR2,
    signalProcess,
    signalProcessGroup,
    sleep,
    softwareStop,
    softwareTermination,
    unBlockSignals,
    userDefinedSignal1,
    userDefinedSignal2,

    ExitCode

    ) where

import GHC.IOBase

import Foreign
import Foreign.C

import GlaExts
import StablePtr    ( newStablePtr, deRefStablePtr )
import Addr	    ( nullAddr )

import PosixErr
import PosixUtil
import CString ( unvectorize, packStringIO,
		 allocChars, freeze, vectorize,
		 allocWords, strcpy
	       )

import System(ExitCode(..))
import PosixProcEnv (getProcessID)

forkProcess :: IO (Maybe ProcessID)
forkProcess = do
    pid <-_ccall_ fork
    case (pid::Int) of
      -1 -> syserr "forkProcess"
      0  -> return Nothing
      _  -> return (Just pid)


executeFile :: FilePath			    -- Command
            -> Bool			    -- Search PATH?
            -> [String]			    -- Arguments
            -> Maybe [(String, String)]	    -- Environment
            -> IO ()
executeFile path search args Nothing = do
  withCString path $ \s ->
    withMany withCString (path:args) $ \cstrs ->
      withArray0 nullPtr cstrs $ \arr -> do
	pPrPr_disableITimers
	if search 
	   then throwErrnoIfMinus1_ "executeFile" (c_execvp s arr)
	   else throwErrnoIfMinus1_ "executeFile" (c_execv s arr)

executeFile path search args (Just env) = do
  withCString path $ \s ->
    withMany withCString (path:args) $ \cstrs ->
      withArray0 nullPtr cstrs $ \arg_arr ->
    let env' = map (\ (name, val) -> name ++ ('=' : val)) env in
    withMany withCString env' $ \cenv ->
      withArray0 nullPtr cenv $ \env_arr -> do
	pPrPr_disableITimers
	if search 
	   then throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr)
	   else throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr)

foreign import ccall unsafe "pPrPr_disableITimers"
  pPrPr_disableITimers :: IO ()

foreign import ccall unsafe "execvp"
  c_execvp :: CString -> Ptr CString -> IO CInt

foreign import ccall unsafe "execv"
  c_execv :: CString -> Ptr CString -> IO CInt

foreign import ccall unsafe "execvpe"
  c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt

foreign import ccall unsafe "execve"
  c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt

data ProcessStatus = Exited ExitCode
                   | Terminated Signal
                   | Stopped Signal
		   deriving (Eq, Ord, Show)

getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
getProcessStatus block stopped pid = do
    wstat <- allocWords 1
    pid   <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat
		(waitOptions block stopped)
    case (pid::Int) of
      -1 -> syserr "getProcessStatus"
      0  -> return Nothing
      _  -> do ps <- decipherWaitStatus wstat
	       return (Just ps)

getGroupProcessStatus :: Bool
                      -> Bool
                      -> ProcessGroupID
                      -> IO (Maybe (ProcessID, ProcessStatus))
getGroupProcessStatus block stopped pgid = do
    wstat <- allocWords 1
    pid   <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat
		   (waitOptions block stopped)
    case (pid::Int) of
      -1 -> syserr "getGroupProcessStatus"
      0  -> return Nothing
      _  -> do ps <- decipherWaitStatus wstat
	       return (Just (pid, ps))

getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus block stopped =
    getGroupProcessStatus block stopped 1	    `catch`
    \ _err -> syserr "getAnyProcessStatus"

exitImmediately :: ExitCode -> IO ()
exitImmediately exitcode = do
    _casm_ ``_exit(%0);'' (exitcode2Int exitcode)
    syserr "exitImmediately"
  where
    exitcode2Int ExitSuccess = 0
    exitcode2Int (ExitFailure n) = n

getEnvironment :: IO [(String, String)]
getEnvironment = do
    --WAS: env  <- unvectorize ``environ'' 0
    -- does not work too well, since the lit-lit
    -- is turned into an Addr that is only evaluated
    -- once (environ is changed to point the most
    -- current env. block after the addition of new entries).
    envp <- _casm_ `` %r=environ; ''
    env  <- unvectorize (envp::Addr) 0
    return (map (split "") env)
  where
    split :: String -> String -> (String, String)
    split x [] = error ("PosixProcPrim.getEnvironment:no `='? in: "++reverse x)
    split x ('=' : xs) = (reverse x, xs)
    split x (c:cs) = split (c:x) cs

setEnvironment :: [(String, String)] -> IO ()
setEnvironment pairs = do
    env <- vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
    nonzero_error (_casm_ ``%r = setenviron((char **)%0);'' env)
	"setEnvironment"

getEnvVar :: String -> IO String
getEnvVar name = do
    str <- packStringIO name
    str <- _ccall_ getenv str
    if str == nullAddr
       then ioException (IOError Nothing NoSuchThing
	   "getEnvVar" "no such environment variable" Nothing)
       else strcpy str

setEnvVar :: String -> String -> IO ()
setEnvVar name value = do
    str <- packStringIO (name ++ ('=' : value))
    nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"

removeEnvVar :: String -> IO ()
removeEnvVar name = do
    str <- packStringIO name
    nonzero_error (_ccall_ delenv str) "removeEnvVar"

type Signal = Int

nullSignal :: Signal
nullSignal = 0

backgroundRead, sigTTIN :: Signal
backgroundRead = ``SIGTTIN''
sigTTIN = ``SIGTTIN''

backgroundWrite, sigTTOU :: Signal
backgroundWrite = ``SIGTTOU''
sigTTOU = ``SIGTTOU''

#ifndef cygwin32_TARGET_OS
continueProcess, sigCONT :: Signal
continueProcess = ``SIGCONT''
sigCONT = ``SIGCONT''
#endif

floatingPointException, sigFPE :: Signal
floatingPointException = ``SIGFPE''
sigFPE = ``SIGFPE''

illegalInstruction, sigILL :: Signal
illegalInstruction = ``SIGILL''
sigILL = ``SIGILL''

internalAbort, sigABRT ::Signal
internalAbort = ``SIGABRT''
sigABRT = ``SIGABRT''

keyboardSignal, sigINT :: Signal
keyboardSignal = ``SIGINT''
sigINT = ``SIGINT''

keyboardStop, sigTSTP :: Signal
keyboardStop = ``SIGTSTP''
sigTSTP = ``SIGTSTP''

keyboardTermination, sigQUIT :: Signal
keyboardTermination = ``SIGQUIT''
sigQUIT = ``SIGQUIT''

killProcess, sigKILL :: Signal
killProcess = ``SIGKILL''
sigKILL = ``SIGKILL''

lostConnection, sigHUP :: Signal
lostConnection = ``SIGHUP''
sigHUP = ``SIGHUP''

openEndedPipe, sigPIPE :: Signal
openEndedPipe = ``SIGPIPE''
sigPIPE = ``SIGPIPE''

processStatusChanged, sigCHLD :: Signal
processStatusChanged = ``SIGCHLD''
sigCHLD = ``SIGCHLD''

realTimeAlarm, sigALRM :: Signal
realTimeAlarm = ``SIGALRM''
sigALRM = ``SIGALRM''

segmentationViolation, sigSEGV :: Signal
segmentationViolation = ``SIGSEGV''
sigSEGV = ``SIGSEGV''

softwareStop, sigSTOP :: Signal
softwareStop = ``SIGSTOP''
sigSTOP = ``SIGSTOP''

softwareTermination, sigTERM :: Signal
softwareTermination = ``SIGTERM''
sigTERM = ``SIGTERM''

userDefinedSignal1, sigUSR1 :: Signal
userDefinedSignal1 = ``SIGUSR1''
sigUSR1 = ``SIGUSR1''

userDefinedSignal2, sigUSR2 :: Signal
userDefinedSignal2 = ``SIGUSR2''
sigUSR2 = ``SIGUSR2''

signalProcess :: Signal -> ProcessID -> IO ()
signalProcess int pid =
    nonzero_error (_ccall_ kill pid int) "signalProcess"

raiseSignal :: Signal -> IO ()
raiseSignal int = getProcessID >>= signalProcess int

signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
signalProcessGroup int pgid = signalProcess int (-pgid)

setStoppedChildFlag :: Bool -> IO Bool
setStoppedChildFlag b = do
    rc <- _casm_ ``%r = nocldstop; nocldstop = %0;'' (x::Int)
    return (rc == (0::Int))
  where
    x = case b of {True -> 0; False -> 1}

queryStoppedChildFlag :: IO Bool
queryStoppedChildFlag = do
    rc <- _casm_ ``%r = nocldstop;''
    return (rc == (0::Int))

data Handler = Default
             | Ignore
             | Catch (IO ())

type SignalSet = ByteArray Int

sigSetSize :: Int
sigSetSize = ``sizeof(sigset_t)''

emptySignalSet :: SignalSet
emptySignalSet = unsafePerformIO $ do
    bytes <- allocChars sigSetSize
    _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
    freeze bytes

fullSignalSet :: SignalSet
fullSignalSet = unsafePerformIO $ do
    bytes <- allocChars sigSetSize
    _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
    freeze bytes

addSignal :: Signal -> SignalSet -> SignalSet
addSignal int oldset = unsafePerformIO $ do
    bytes <- allocChars sigSetSize
    _ccall_ stg_sigaddset bytes oldset int
    freeze bytes

inSignalSet :: Signal -> SignalSet -> Bool
inSignalSet int sigset = unsafePerformIO $ do
    rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
    return (rc == (1::Int))

deleteSignal :: Signal -> SignalSet -> SignalSet
deleteSignal int oldset = unsafePerformIO $ do
    bytes <- allocChars sigSetSize
    _ccall_ stg_sigdelset bytes oldset int
    freeze bytes

installHandler :: Signal
               -> Handler
               -> Maybe SignalSet	-- other signals to block
               -> IO Handler		-- old handler

#ifdef __PARALLEL_HASKELL__
installHandler = 
  error "installHandler: not available for Parallel Haskell"
#else
installHandler int handler maybe_mask = (
    case handler of
      Default -> _ccall_ stg_sig_default int mask
      Ignore  -> _ccall_ stg_sig_ignore  int mask
      Catch m -> do
        sptr <- newStablePtr m
	_ccall_ stg_sig_catch int sptr mask
    ) >>= \rc ->

    if rc >= (0::Int) then do
        osptr <- _casm_ ``%r = (StgStablePtr) (%0);'' rc
        m     <- deRefStablePtr osptr
	return (Catch m)
    else if rc == ``STG_SIG_DFL'' then
	return Default
    else if rc == ``STG_SIG_IGN'' then
	return Ignore
    else
	syserr "installHandler"
  where
    mask = case maybe_mask of
	     Nothing -> emptySignalSet
             Just x -> x

#endif {-!__PARALLEL_HASKELL__-}

getSignalMask :: IO SignalSet
getSignalMask = do
    bytes <- allocChars sigSetSize
    rc    <- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
    if rc == (0::Int)
       then freeze bytes
       else syserr "getSignalMask"

sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
sigProcMask name how sigset = do
    bytes <- allocChars sigSetSize
    rc <- _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);''
		 how sigset bytes
    if rc == (0::Int)
       then freeze bytes
       else syserr name

setSignalMask :: SignalSet -> IO SignalSet
setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''

blockSignals :: SignalSet -> IO SignalSet
blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''

unBlockSignals :: SignalSet -> IO SignalSet
unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''

getPendingSignals :: IO SignalSet
getPendingSignals = do
    bytes <- allocChars sigSetSize
    rc <- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
    if rc == (0::Int)
       then freeze bytes
       else syserr "getPendingSignals"

#ifndef cygwin32_TARGET_OS
awaitSignal :: Maybe SignalSet -> IO ()
awaitSignal maybe_sigset = do
    pause maybe_sigset
    err <- getErrorCode
    if err == interruptedOperation
       then return ()
       else syserr "awaitSignal"

pause :: Maybe SignalSet -> IO ()
pause maybe_sigset =
  case maybe_sigset of
   Nothing -> _casm_ ``(void) pause();''
   Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
#endif

scheduleAlarm :: Int -> IO Int
scheduleAlarm (I# secs#) =
    _ccall_ alarm (W# (int2Word# secs#))	    >>= \ (W# w#) ->
    return (I# (word2Int# w#))

sleep :: Int -> IO ()
sleep 0 = return ()
sleep (I# secs#) = do
    _ccall_ sleep (W# (int2Word# secs#))
    return ()
\end{code}

Local utility functions

\begin{code}

-- Convert wait options to appropriate set of flags

waitOptions :: Bool -> Bool -> Int
--             block   stopped
waitOptions False False = ``WNOHANG''
waitOptions False True  = ``(WNOHANG|WUNTRACED)''
waitOptions True  False = 0
waitOptions True  True  = ``WUNTRACED''

-- Turn a (ptr to a) wait status into a ProcessStatus

decipherWaitStatus :: MutableByteArray RealWorld x -> IO ProcessStatus
decipherWaitStatus wstat = do
    exited <- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat
    if exited /= (0::Int)
      then do
        exitstatus <- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
        if exitstatus == (0::Int)
	   then return (Exited ExitSuccess)
	   else return (Exited (ExitFailure exitstatus))
      else do
        signalled <- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
        if signalled /= (0::Int)
	   then do
		termsig <- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
		return (Terminated termsig)
	   else do
		stopsig <-_casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
		return (Stopped stopsig)
\end{code}
