Basic.hs

module RawFilePath.Process.Basic where

-- base modules

import RawFilePath.Import hiding (ClosedHandle)

-- local modules

import RawFilePath.Process.Common
import RawFilePath.Process.Internal
import RawFilePath.Process.Posix

-- | Start a new sub-process with the given configuration.
startProcess
    :: (StreamType stdin, StreamType stdout, StreamType stderr)
    => ProcessConf stdin stdout stderr
    -> IO (Process stdin stdout stderr)
startProcess = createProcessInternal

-- | Stop a sub-process. For now it simply calls 'terminateProcess' and then
-- 'waitForProcess'.
stopProcess :: Process stdin stdout stderr -> IO ExitCode
stopProcess p = do
    terminateProcess p
    waitForProcess p

-- | Wait (block) for a sub-process to exit and obtain its exit code.
waitForProcess
  :: Process stdin stdout stderr
  -> IO ExitCode
waitForProcess ph = lockWaitpid $ do
  p_ <- modifyProcessHandle ph $ \ p_ -> return (p_,p_)
  case p_ of
    ClosedHandle e -> return e
    OpenHandle h  -> do
        e <- alloca $ \ pret -> do
          -- don't hold the MVar while we call c_waitForProcess...
          throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
          modifyProcessHandle ph $ \ p_' ->
            case p_' of
              ClosedHandle e  -> return (p_', e)
              OpenExtHandle{} -> return (p_', ExitFailure (-1))
              OpenHandle ph'  -> do
                closePHANDLE ph'
                code <- peek pret
                let e = if code == 0
                       then ExitSuccess
                       else ExitFailure (fromIntegral code)
                return (ClosedHandle e, e)
        when delegatingCtlc $
          endDelegateControlC e
        return e
    OpenExtHandle _ _job _iocp ->
        return $ ExitFailure (-1)
  where
    -- If more than one thread calls `waitpid` at a time, `waitpid` will
    -- return the exit code to one of them and (-1) to the rest of them,
    -- causing an exception to be thrown.
    -- Cf. https://github.com/haskell/process/issues/46, and
    -- https://github.com/haskell/process/pull/58 for further discussion
    lockWaitpid m = withMVar (waitpidLock ph) $ \ () -> m
    delegatingCtlc = mbDelegateCtlc ph

-- | Terminate a sub-process by sending SIGTERM to it.
terminateProcess :: Process stdin stdout stderr -> IO ()
terminateProcess p = withProcessHandle p $ \ case
    ClosedHandle  _ -> return ()
    OpenExtHandle{} -> error
        "terminateProcess with OpenExtHandle should not happen on POSIX."
    OpenHandle    h -> do
        throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h
        return ()
        -- does not close the handle, we might want to try terminating it
        -- again, or get its exit code.