-- Posix extras module from http://web.archiveorange.com/archive/v/2B0uXg72rgFNm2yKVyxc (Glasgow Haskell mailing list)
-- Wait4 haskell implementation

-- $Id$

module PosixExtras
(
  ProcessResourceUsage(..),
  reapChildProcess
)
where

import Ratio
import System
import System.Posix hiding (userTime, systemTime)
import System.IO.Error
import Foreign
import Foreign.C
import Data.Time.Clock


data ProcessResourceUsage = ProcessResourceUsage { userTime, systemTime :: DiffTime }
                          deriving (Show)


reapChildProcess :: Bool -> Bool -> ProcessID
        -> IO (Maybe (ProcessID, ProcessStatus, ProcessResourceUsage))
reapChildProcess block stopped pid = alloca $ \p_wstat ->
  allocaBytes structRusageSize $ \p_sru -> do
    pid' <- throwErrnoIfMinus1 "reapChildProcess"
              (c_wait4 (fromIntegral pid) p_wstat
                       (waitOptions block stopped) p_sru)
    case pid' of
      0 -> return Nothing
      _ -> do ps  <- decipherWaitStatus p_wstat
              pru <- makeProcessResourceUsage p_sru
              return (Just (fromIntegral pid', ps, pru))


structRusageSize = 144  -- I think it's 72.  Include 100% slop.

type CRusage = CInt  -- cheat

makeProcessResourceUsage :: Ptr CInt -> IO ProcessResourceUsage
makeProcessResourceUsage p_sru = do
  -- Assume that ru_utime and ru_stime are at the beginning of struct rusage.
  [uhi, ulo, shi, slo] <- mapM get [0..3]
  let u = time uhi ulo
      s = time shi slo
  return $ ProcessResourceUsage{ userTime = u, systemTime = s }
 where
  get n = fmap fromIntegral $ peekElemOff p_sru n
  time hi lo = picosecondsToDiffTime ((fromIntegral hi)*10^6 + ((fromIntegral lo)))*10^6

foreign import ccall unsafe "wait4"
   c_wait4 :: CPid -> Ptr CInt -> CInt -> Ptr CRusage -> IO CPid

-- The following was scarfed from
-- fptools/libraries/unix/System/Posix/Process.hsc?rev=1.4

waitOptions :: Bool -> Bool -> CInt
--             block   stopped
waitOptions False False = 1 -- (#const WNOHANG)
waitOptions False True  = 3 -- (#const (WNOHANG|WUNTRACED))
waitOptions True  False = 0
waitOptions True  True  = 2 -- (#const WUNTRACED)

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

decipherWaitStatus :: Ptr CInt -> IO ProcessStatus
decipherWaitStatus wstatp = do
  wstat <- peek wstatp
  if c_WIFEXITED wstat /= 0
      then do
        let exitstatus = c_WEXITSTATUS wstat
        if exitstatus == 0
           then return (Exited ExitSuccess)
           else return (Exited (ExitFailure (fromIntegral exitstatus)))
      else do
        if c_WIFSIGNALED wstat /= 0
           then do
                let termsig = c_WTERMSIG wstat
                return (Terminated (fromIntegral termsig))
           else do
                if c_WIFSTOPPED wstat /= 0
                   then do
                        let stopsig = c_WSTOPSIG wstat
                        return (Stopped (fromIntegral stopsig))
                   else do
                        ioError (mkIOError illegalOperationErrorType
                                   "waitStatus" Nothing Nothing)

{-

foreign import ccall unsafe "__hsunix_wifexited"
  c_WIFEXITED :: CInt -> CInt

foreign import ccall unsafe "__hsunix_wexitstatus"
  c_WEXITSTATUS :: CInt -> CInt

foreign import ccall unsafe "__hsunix_wifsignaled"
  c_WIFSIGNALED :: CInt -> CInt

foreign import ccall unsafe "__hsunix_wtermsig"
  c_WTERMSIG :: CInt -> CInt

foreign import ccall unsafe "__hsunix_wifstopped"
  c_WIFSTOPPED :: CInt -> CInt

foreign import ccall unsafe "__hsunix_wstopsig"
  c_WSTOPSIG :: CInt -> CInt

-}

c_WIFEXITED :: CInt -> CInt
c_WIFEXITED c = h2c $ fromEnum $ low7 (c2h c) == 0

c_WEXITSTATUS :: CInt -> CInt
c_WEXITSTATUS c = h2c $ high8 $ c2h c

c_WIFSIGNALED :: CInt -> CInt
c_WIFSIGNALED c = h2c $ fromEnum $ c_WIFSTOPPED c /= 0 && c_WIFEXITED c /= 0

c_WTERMSIG :: CInt -> CInt
c_WTERMSIG c = h2c $ low7 $ c2h c

c_WIFSTOPPED :: CInt -> CInt
c_WIFSTOPPED c = h2c $ fromEnum $ low8 (c2h c) == 127

c_WSTOPSIG :: CInt -> CInt
c_WSTOPSIG c = h2c $ high8 $ c2h c

low7  x = x `rem` 128
low8  x = x `rem` 256
high8 x = x `div` 256

c2h = fromIntegral
h2c = fromIntegral