-- |
-- Module      : Streamly.Internal.System.Process.Posix
-- Copyright   : (c) 2020 Composewell Technologies
-- License     : Apache-2.0
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Streamly.Internal.System.Process.Posix
    (
    -- * Processes
      Process
    , newProcess
    , wait
    , getStatus

    -- * IPC
    , mkPipe
    , mkStdioPipes
    )
where

import Control.Concurrent
    (MVar, newMVar, readMVar, withMVar, modifyMVar, modifyMVar_)
import Control.Exception (catch, throwIO, Exception(..), onException)
import Control.Monad (void)
import Data.Bifunctor (first)
import Data.Tuple (swap)
import GHC.IO.Device (IODeviceType(..))
import GHC.IO.Encoding (getLocaleEncoding)
import GHC.IO.Handle.FD (mkHandleFromFD)
import System.IO (IOMode(..), Handle)
import System.IO.Error (isDoesNotExistError)
import System.Posix.IO (createPipe, dupTo, closeFd)
import System.Posix.Process (forkProcess, executeFile, ProcessStatus)
import System.Posix.Types (ProcessID, Fd(..), CDev, CIno)
import System.Posix.Internals (fdGetMode)

import qualified GHC.IO.FD as FD
import qualified System.Posix.Process as Posix

-------------------------------------------------------------------------------
-- Utilities to create stdio handles
-------------------------------------------------------------------------------

-- See GHC.IO.Handle.FD
-- We have to put the FDs into binary mode on Windows to avoid the newline
-- translation that the CRT IO library does.
setBinaryMode :: FD.FD -> IO ()
#if defined(mingw32_HOST_OS)
setBinaryMode fd = do
    _ <- setmode (FD.fdFD fd) True
    return ()
#else
setBinaryMode :: FD -> IO ()
setBinaryMode FD
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

-- See Posix.fdToHandle and GHC.IO.Handle.FD.fdToHandle
-- See stdin, stdout, stderr in module GHC.IO.Handle.FD
--
-- This routines avoids a few system calls and does a few more things compared
-- to fdToHandle.
stdioFdToHandle ::
    Bool -> Maybe IOMode -> Maybe (IODeviceType, CDev, CIno) -> Fd -> IO Handle
stdioFdToHandle :: Bool
-> Maybe IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Fd
-> IO Handle
stdioFdToHandle Bool
binary Maybe IOMode
mbIOMode Maybe (IODeviceType, CDev, CIno)
mbStat (Fd CInt
fdint) = do
    IOMode
iomode <-
        case Maybe IOMode
mbIOMode of
            Just IOMode
mode -> IOMode -> IO IOMode
forall (m :: * -> *) a. Monad m => a -> m a
return IOMode
mode
            Maybe IOMode
Nothing -> CInt -> IO IOMode
fdGetMode CInt
fdint
    (FD
fd, IODeviceType
fd_type) <- CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD CInt
fdint IOMode
iomode Maybe (IODeviceType, CDev, CIno)
mbStat
            Bool
False{-is_socket-}
              -- NB. the is_socket flag is False, meaning that:
              -- on Windows we're guessing this is not a socket (XXX)
            Bool
False{-is_nonblock-}
              -- file descriptors that we get from external sources are
              -- not put into non-blocking mode, because that would affect
              -- other users of the file descriptor
    FD -> IO ()
setBinaryMode FD
fd
    Maybe TextEncoding
enc <- if Bool
binary then Maybe TextEncoding -> IO (Maybe TextEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TextEncoding
forall a. Maybe a
Nothing else (TextEncoding -> Maybe TextEncoding)
-> IO TextEncoding -> IO (Maybe TextEncoding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just IO TextEncoding
getLocaleEncoding
    -- Should we set the FD non-blocking?
    -- See https://gitlab.haskell.org/ghc/ghc/-/issues/3316
    let fd_str :: [Char]
fd_str = [Char]
"<stdioFdToHandle file descriptor: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FD -> [Char]
forall a. Show a => a -> [Char]
show FD
fd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
    FD
-> IODeviceType
-> [Char]
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
mkHandleFromFD FD
fd IODeviceType
fd_type [Char]
fd_str IOMode
iomode Bool
True{-non-block-} Maybe TextEncoding
enc

-------------------------------------------------------------------------------
-- Setup pipes between parent and child processes
-------------------------------------------------------------------------------

-- | ParentToChild: parent writes, child reads
data Direction = ParentToChild | ChildToParent deriving (Int -> Direction -> [Char] -> [Char]
[Direction] -> [Char] -> [Char]
Direction -> [Char]
(Int -> Direction -> [Char] -> [Char])
-> (Direction -> [Char])
-> ([Direction] -> [Char] -> [Char])
-> Show Direction
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Direction] -> [Char] -> [Char]
$cshowList :: [Direction] -> [Char] -> [Char]
show :: Direction -> [Char]
$cshow :: Direction -> [Char]
showsPrec :: Int -> Direction -> [Char] -> [Char]
$cshowsPrec :: Int -> Direction -> [Char] -> [Char]
Show, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq)

-- | return (parent, child, (parentAction, childAction, failureAction))
mkPipe :: Direction -> IO (Fd, Fd, (IO (), IO (), IO ()))
mkPipe :: Direction -> IO (Fd, Fd, (IO (), IO (), IO ()))
mkPipe Direction
direction = do
    let setDirection :: (a, a) -> (a, a)
setDirection = if Direction
direction Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
ParentToChild then (a, a) -> (a, a)
forall a. a -> a
id else (a, a) -> (a, a)
forall a b. (a, b) -> (b, a)
swap
    (Fd
child, Fd
parent) <- ((Fd, Fd) -> (Fd, Fd)) -> IO (Fd, Fd) -> IO (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fd, Fd) -> (Fd, Fd)
forall a. (a, a) -> (a, a)
setDirection IO (Fd, Fd)
createPipe
    let parentAction :: IO ()
parentAction = Fd -> IO ()
closeFd Fd
child
        childAction :: IO ()
childAction = Fd -> IO ()
closeFd Fd
parent
        failureAction :: IO ()
failureAction = Fd -> IO ()
closeFd Fd
child IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
parent
    (Fd, Fd, (IO (), IO (), IO ()))
-> IO (Fd, Fd, (IO (), IO (), IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd
parent, Fd
child, (IO ()
parentAction, IO ()
childAction, IO ()
failureAction))

-- | The child end of the pipe is duped to the supplied fd. The parent side fd
-- of the pipe is returned.
mkPipeDupChild :: Direction -> Fd -> IO (Fd, (IO (), IO (), IO ()))
mkPipeDupChild :: Direction -> Fd -> IO (Fd, (IO (), IO (), IO ()))
mkPipeDupChild Direction
direction Fd
childFd = do
    let setDirection :: (a, a) -> (a, a)
setDirection = if Direction
direction Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
ParentToChild then (a, a) -> (a, a)
forall a. a -> a
id else (a, a) -> (a, a)
forall a b. (a, b) -> (b, a)
swap
    (Fd
child, Fd
parent) <- ((Fd, Fd) -> (Fd, Fd)) -> IO (Fd, Fd) -> IO (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fd, Fd) -> (Fd, Fd)
forall a. (a, a) -> (a, a)
setDirection IO (Fd, Fd)
createPipe
    let parentAction :: IO ()
parentAction = Fd -> IO ()
closeFd Fd
child
        childAction :: IO ()
childAction =
            Fd -> IO ()
closeFd Fd
parent IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Fd -> Fd -> IO Fd
dupTo Fd
child Fd
childFd) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
child
        failureAction :: IO ()
failureAction = Fd -> IO ()
closeFd Fd
child IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
closeFd Fd
parent
    (Fd, (IO (), IO (), IO ())) -> IO (Fd, (IO (), IO (), IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd
parent, (IO ()
parentAction, IO ()
childAction, IO ()
failureAction))

-- XXX We could possibly combine the triples from individual pipes in a more
-- idiomatic manner.
mkStdioPipes :: Bool -> IO ((Handle, Handle, Maybe Handle, Handle, Handle), IO (), IO (), IO ())
mkStdioPipes :: Bool
-> IO
     ((Handle, Handle, Maybe Handle, Handle, Handle), IO (), IO (),
      IO ())
mkStdioPipes Bool
pipeStdErr = do
    -- stdin
    (Fd
inp, (IO ()
inpParent, IO ()
inpChild, IO ()
inpFail)) <- Direction -> Fd -> IO (Fd, (IO (), IO (), IO ()))
mkPipeDupChild Direction
ParentToChild Fd
0

    -- stdout
    (Fd
out, (IO ()
outParent, IO ()
outChild, IO ()
outFail)) <- Direction -> Fd -> IO (Fd, (IO (), IO (), IO ()))
mkPipeDupChild Direction
ChildToParent Fd
1
        IO (Fd, (IO (), IO (), IO ()))
-> IO () -> IO (Fd, (IO (), IO (), IO ()))
forall a b. IO a -> IO b -> IO a
`onException` IO ()
inpFail

    -- stderr
    (Maybe Fd
err, (IO ()
errParent, IO ()
errChild, IO ()
errFail)) <-
        if Bool
pipeStdErr
        then (Fd -> Maybe Fd)
-> (Fd, (IO (), IO (), IO ())) -> (Maybe Fd, (IO (), IO (), IO ()))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Fd -> Maybe Fd
forall a. a -> Maybe a
Just ((Fd, (IO (), IO (), IO ())) -> (Maybe Fd, (IO (), IO (), IO ())))
-> IO (Fd, (IO (), IO (), IO ()))
-> IO (Maybe Fd, (IO (), IO (), IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Direction -> Fd -> IO (Fd, (IO (), IO (), IO ()))
mkPipeDupChild Direction
ChildToParent Fd
2
                IO (Fd, (IO (), IO (), IO ()))
-> IO () -> IO (Fd, (IO (), IO (), IO ()))
forall a b. IO a -> IO b -> IO a
`onException` (IO ()
inpFail IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
outFail)
        else (Maybe Fd, (IO (), IO (), IO ()))
-> IO (Maybe Fd, (IO (), IO (), IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Fd
forall a. Maybe a
Nothing, (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (), () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (), () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

    {-
    -- exception channel
    (efdParent, efdChild, (excParent, excChild, excFail)) <-
        mkPipe ChildToParent
            `onException` (inpFail >> outFail >> errFail)
    -}

    let parentAction :: IO ()
parentAction = IO ()
inpParent IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
outParent IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
errParent -- >> excParent
        childAction :: IO ()
childAction = IO ()
inpChild IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
outChild IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
errChild -- >> excChild
        failureAction :: IO ()
failureAction = IO ()
inpFail IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
outFail IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
errFail -- >> excFail

    Handle
inpH <- IOMode -> Fd -> IO Handle
toHandle IOMode
WriteMode Fd
inp
    Handle
outH <- IOMode -> Fd -> IO Handle
toHandle IOMode
ReadMode Fd
out
    Maybe Handle
errH <-
        case Maybe Fd
err of
            Just Fd
x -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOMode -> Fd -> IO Handle
toHandle IOMode
ReadMode Fd
x
            Maybe Fd
Nothing -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
    -- ehParent <- stdioFdToHandle
    --                  True (Just ReadMode) (Just (Stream, 0, 0)) efdParent
    -- ehChild Paren<- stdioFdToHandle
    --                  True (Just ReadMode) (Just (Stream, 0, 0)) efdChild
    let ehParent :: a
ehParent = a
forall a. HasCallStack => a
undefined
    let ehChild :: a
ehChild = a
forall a. HasCallStack => a
undefined
    ((Handle, Handle, Maybe Handle, Handle, Handle), IO (), IO (),
 IO ())
-> IO
     ((Handle, Handle, Maybe Handle, Handle, Handle), IO (), IO (),
      IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( (Handle
inpH, Handle
outH, Maybe Handle
errH, Handle
forall a. a
ehParent, Handle
forall a. a
ehChild)
           , IO ()
parentAction
           , IO ()
childAction
           , IO ()
failureAction
           )

    where

    toHandle :: IOMode -> Fd -> IO Handle
toHandle IOMode
mode = Bool
-> Maybe IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Fd
-> IO Handle
stdioFdToHandle Bool
False (IOMode -> Maybe IOMode
forall a. a -> Maybe a
Just IOMode
mode) ((IODeviceType, CDev, CIno) -> Maybe (IODeviceType, CDev, CIno)
forall a. a -> Maybe a
Just (IODeviceType
Stream, CDev
0, CIno
0))

-------------------------------------------------------------------------------
-- Process handle
-------------------------------------------------------------------------------

-- Note: We have two types of users reading and modifying the process handle,
-- (1) blocking waiters - wait, (2) non-blocking users -
-- getStatus. We need to ensure that blocking waiters always get the
-- status, and non-blocking waiters always get the status if the process is
-- done otherwise return Nothing.
--
-- One locking strategy could be that blocking waiters take a lock, and
-- non-blocking waiters try the same lock and if they cannot acquire it then
-- return Nothing. But the problem with this is that even after the process is
-- done non-blocking waiters locking may fail due to contention and it may
-- return Nothing, which is wrong.
--
-- Instead we use the following strategy.  Everyone first looks up the status
-- under the ProcessStatus lock. If the process is done we return the status.
-- If not done then:
--
-- - blocking users take the "waitlock" and perform a blocking waitpid, then
-- update the status by taking the ProcessStatus lock. This ensures that all
-- the blocking waiters are synchronized.
--
-- - non-blocking users perform non-blocking waitpid under the ProcessStatus
-- lock, this ensures that blocking users will not miss a reaping done by
-- non-blocking users. But non-blocking users may still miss a reaping done by
-- blocking users, if a blocking user reaped but is waiting for ProcessStatus
-- lock to update it. To take care of that case non-blocking users use the
-- result of waitpid to detect if the process has already been reaped and if so
-- they try again using the blocking users' waitlock. We know that this cannot
-- block for a long time any more since the process has been reaped. This time
-- if we still cannot get the status then it is some real error or bug so we
-- raise an exception.
--
-- | Thread safe, mutable process handle. Process status is stored in the
-- handle and is modified by the process inspection operations.
data Process =
    Process
        ProcessID -- Read only
        (MVar ()) -- waitlock
        (MVar (Maybe ProcessStatus)) -- ProcessStatus lock

-------------------------------------------------------------------------------
-- Creating a Process
-------------------------------------------------------------------------------

-- If this API is to be exported then we should wrap it in another function
-- that checks if the pid really exists by doing a non-blocking waitpid on it.
--
-- | Turn an existing process pid into a 'Process' handle.
pidToProcess :: ProcessID -> Maybe ProcessStatus -> IO Process
pidToProcess :: ProcessID -> Maybe ProcessStatus -> IO Process
pidToProcess ProcessID
pid Maybe ProcessStatus
status = do
    MVar ()
waitLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    MVar (Maybe ProcessStatus)
st <- Maybe ProcessStatus -> IO (MVar (Maybe ProcessStatus))
forall a. a -> IO (MVar a)
newMVar Maybe ProcessStatus
status
    Process -> IO Process
forall (m :: * -> *) a. Monad m => a -> m a
return (Process -> IO Process) -> Process -> IO Process
forall a b. (a -> b) -> a -> b
$ ProcessID -> MVar () -> MVar (Maybe ProcessStatus) -> Process
Process ProcessID
pid MVar ()
waitLock MVar (Maybe ProcessStatus)
st

-- | Creates a new process, executes the specified action in the cloned process
-- and then performs an @exec@ system call using the provided path, arguments
-- and environment. The PATH is searched for the specified binary when the
-- specified path is not absolute?
newProcess ::
       IO ()                    -- ^ Execute after fork, before exec
    -> FilePath                 -- ^ Executable path
    -> [String]                 -- ^ Arguments
    -> Maybe [(String, String)] -- ^ Environment
    -> IO Process
newProcess :: IO ()
-> [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> IO Process
newProcess IO ()
action [Char]
path [[Char]]
args Maybe [([Char], [Char])]
env = do
    ProcessID
pid <- IO () -> IO ProcessID
forkProcess IO ()
forall b. IO b
exec
    ProcessID -> Maybe ProcessStatus -> IO Process
pidToProcess ProcessID
pid Maybe ProcessStatus
forall a. Maybe a
Nothing

    where

    -- XXX What if exec failed or the "action" failed? Need to send the error
    -- to the parent and clean up the parent fds. We can send the exceptions
    -- via a pipe like we do for threads.
    --
    exec :: IO b
exec = IO ()
action IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Bool -> [[Char]] -> Maybe [([Char], [Char])] -> IO b
forall a.
[Char] -> Bool -> [[Char]] -> Maybe [([Char], [Char])] -> IO a
executeFile [Char]
path Bool
True [[Char]]
args Maybe [([Char], [Char])]
env

newtype ProcessDoesNotExist = ProcessDoesNotExist ProcessID deriving Int -> ProcessDoesNotExist -> [Char] -> [Char]
[ProcessDoesNotExist] -> [Char] -> [Char]
ProcessDoesNotExist -> [Char]
(Int -> ProcessDoesNotExist -> [Char] -> [Char])
-> (ProcessDoesNotExist -> [Char])
-> ([ProcessDoesNotExist] -> [Char] -> [Char])
-> Show ProcessDoesNotExist
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ProcessDoesNotExist] -> [Char] -> [Char]
$cshowList :: [ProcessDoesNotExist] -> [Char] -> [Char]
show :: ProcessDoesNotExist -> [Char]
$cshow :: ProcessDoesNotExist -> [Char]
showsPrec :: Int -> ProcessDoesNotExist -> [Char] -> [Char]
$cshowsPrec :: Int -> ProcessDoesNotExist -> [Char] -> [Char]
Show

instance Exception ProcessDoesNotExist where

    displayException :: ProcessDoesNotExist -> [Char]
displayException (ProcessDoesNotExist ProcessID
pid) =
        [Char]
"Bug: Process with pid " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessID -> [Char]
forall a. Show a => a -> [Char]
show ProcessID
pid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" does not exist."

-- | Wait until the process exits by itself or gets terminated due to a signal.
-- Returns the 'ProcessStatus' which includes the termination reason or exit
-- code.
--
-- Thread safe.
wait :: Process -> IO ProcessStatus
wait :: Process -> IO ProcessStatus
wait (Process ProcessID
pid MVar ()
waitLock MVar (Maybe ProcessStatus)
procStatus) = do
    Maybe ProcessStatus
status <- MVar (Maybe ProcessStatus) -> IO (Maybe ProcessStatus)
forall a. MVar a -> IO a
readMVar MVar (Maybe ProcessStatus)
procStatus
    case Maybe ProcessStatus
status of
        Just ProcessStatus
st -> ProcessStatus -> IO ProcessStatus
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessStatus
st
        Maybe ProcessStatus
Nothing -> MVar () -> (() -> IO ProcessStatus) -> IO ProcessStatus
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
waitLock ((() -> IO ProcessStatus) -> IO ProcessStatus)
-> (() -> IO ProcessStatus) -> IO ProcessStatus
forall a b. (a -> b) -> a -> b
$ \() -> IO ProcessStatus
waitStatus IO ProcessStatus
-> (IOError -> IO ProcessStatus) -> IO ProcessStatus
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO ProcessStatus
eChild

    where

    waitStatus :: IO ProcessStatus
waitStatus = do
        Maybe ProcessStatus
st <- Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
Posix.getProcessStatus Bool
True{-block-} Bool
False{-stopped-} ProcessID
pid
        case Maybe ProcessStatus
st of
            Maybe ProcessStatus
Nothing -> [Char] -> IO ProcessStatus
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ProcessStatus) -> [Char] -> IO ProcessStatus
forall a b. (a -> b) -> a -> b
$ [Char]
"wait: Bug: Posix.getProcessStatus "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"returned Nothing in blocking mode"
            Just ProcessStatus
s -> do
                MVar (Maybe ProcessStatus)
-> (Maybe ProcessStatus -> IO (Maybe ProcessStatus)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ProcessStatus)
procStatus ((Maybe ProcessStatus -> IO (Maybe ProcessStatus)) -> IO ())
-> (Maybe ProcessStatus -> IO (Maybe ProcessStatus)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ProcessStatus
_ -> Maybe ProcessStatus -> IO (Maybe ProcessStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessStatus
st
                ProcessStatus -> IO ProcessStatus
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessStatus
s

    -- Got eCHILD, some non-blocking user already reaped the process.
    eChild :: IOError -> IO ProcessStatus
eChild IOError
e = do
        if IOError -> Bool
isDoesNotExistError IOError
e
        then do
            Maybe ProcessStatus
st <- MVar (Maybe ProcessStatus) -> IO (Maybe ProcessStatus)
forall a. MVar a -> IO a
readMVar MVar (Maybe ProcessStatus)
procStatus
            case Maybe ProcessStatus
st of
                Maybe ProcessStatus
Nothing -> ProcessDoesNotExist -> IO ProcessStatus
forall e a. Exception e => e -> IO a
throwIO (ProcessDoesNotExist -> IO ProcessStatus)
-> ProcessDoesNotExist -> IO ProcessStatus
forall a b. (a -> b) -> a -> b
$ ProcessID -> ProcessDoesNotExist
ProcessDoesNotExist ProcessID
pid
                Just ProcessStatus
s -> ProcessStatus -> IO ProcessStatus
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessStatus
s
        else IOError -> IO ProcessStatus
forall e a. Exception e => e -> IO a
throwIO IOError
e

-- | Get the current status of a process. A 'Nothing' value means the process
-- is still running, a 'Just' value means the process is terminated and
-- provides the status of the process.
--
-- Thread safe.
--
getStatus :: Process -> IO (Maybe ProcessStatus)
getStatus :: Process -> IO (Maybe ProcessStatus)
getStatus proc :: Process
proc@(Process ProcessID
pid MVar ()
_ MVar (Maybe ProcessStatus)
procStatus) = do
    Maybe (Maybe ProcessStatus)
r <- MVar (Maybe ProcessStatus)
-> (Maybe ProcessStatus
    -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus)))
-> IO (Maybe (Maybe ProcessStatus))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar
            MVar (Maybe ProcessStatus)
procStatus
            ((Maybe ProcessStatus
  -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus)))
 -> IO (Maybe (Maybe ProcessStatus)))
-> (Maybe ProcessStatus
    -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus)))
-> IO (Maybe (Maybe ProcessStatus))
forall a b. (a -> b) -> a -> b
$ \Maybe ProcessStatus
old ->
                case Maybe ProcessStatus
old of
                    Just ProcessStatus
_ -> (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ProcessStatus
old, Maybe ProcessStatus -> Maybe (Maybe ProcessStatus)
forall a. a -> Maybe a
Just Maybe ProcessStatus
old)
                    Maybe ProcessStatus
Nothing -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
fetchStatus IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
-> (IOError
    -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus)))
-> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
forall a a. IOError -> IO (Maybe a, Maybe a)
eChild
    case Maybe (Maybe ProcessStatus)
r of
        Just Maybe ProcessStatus
st -> Maybe ProcessStatus -> IO (Maybe ProcessStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessStatus
st
        Maybe (Maybe ProcessStatus)
Nothing -> ProcessStatus -> Maybe ProcessStatus
forall a. a -> Maybe a
Just (ProcessStatus -> Maybe ProcessStatus)
-> IO ProcessStatus -> IO (Maybe ProcessStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process -> IO ProcessStatus
wait Process
proc

    where

    fetchStatus :: IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
fetchStatus = do
        Maybe ProcessStatus
st <- Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
Posix.getProcessStatus Bool
False{-block-} Bool
False{-stopped-} ProcessID
pid
        (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus, Maybe (Maybe ProcessStatus))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ProcessStatus
st, Maybe ProcessStatus -> Maybe (Maybe ProcessStatus)
forall a. a -> Maybe a
Just Maybe ProcessStatus
st)

    -- Got eCHILD, some blocking user already reaped the process.
    -- We need to go through the blocking wait API to synchronize.
    eChild :: IOError -> IO (Maybe a, Maybe a)
eChild IOError
e = do
        if IOError -> Bool
isDoesNotExistError IOError
e
        then (Maybe a, Maybe a) -> IO (Maybe a, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
        else IOError -> IO (Maybe a, Maybe a)
forall e a. Exception e => e -> IO a
throwIO IOError
e