{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}

module System.Process.CommunicationHandle
  ( -- * 'CommunicationHandle': a 'Handle' that can be serialised,
    -- enabling inter-process communication.
    CommunicationHandle
      -- NB: opaque, as the representation depends on the operating system
  , openCommunicationHandleRead
  , openCommunicationHandleWrite
  , closeCommunicationHandle
    -- * Creating 'CommunicationHandle's to communicate with
    -- a child process
  , createWeReadTheyWritePipe
  , createTheyReadWeWritePipe
   -- * High-level API
  , readCreateProcessWithExitCodeCommunicationHandle
  )
 where

import GHC.IO.Handle (Handle)

import System.Process.CommunicationHandle.Internal
import System.Process.Internals
  ( CreateProcess(..), ignoreSigPipe, withForkWait )
import System.Process
  ( withCreateProcess, waitForProcess )

import GHC.IO (evaluate)
import GHC.IO.Handle (hClose)
import System.Exit (ExitCode)

import Control.DeepSeq (NFData, rnf)

--------------------------------------------------------------------------------
-- Communication handles.

-- | Turn the 'CommunicationHandle' into a 'Handle' that can be read from
-- in the current process.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- @since 1.6.20.0
openCommunicationHandleRead :: CommunicationHandle -> IO Handle
openCommunicationHandleRead :: CommunicationHandle -> IO Handle
openCommunicationHandleRead = Bool -> CommunicationHandle -> IO Handle
useCommunicationHandle Bool
True

-- | Turn the 'CommunicationHandle' into a 'Handle' that can be written to
-- in the current process.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- @since 1.6.20.0
openCommunicationHandleWrite :: CommunicationHandle -> IO Handle
openCommunicationHandleWrite :: CommunicationHandle -> IO Handle
openCommunicationHandleWrite = Bool -> CommunicationHandle -> IO Handle
useCommunicationHandle Bool
False

--------------------------------------------------------------------------------
-- Creating pipes.

-- | Create a pipe @(weRead,theyWrite)@ that the current process can read from,
-- and whose write end can be passed to a child process in order to receive data from it.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createWeReadTheyWritePipe
  :: IO (Handle, CommunicationHandle)
createWeReadTheyWritePipe :: IO (Handle, CommunicationHandle)
createWeReadTheyWritePipe =
  (forall a. (a, a) -> (a, a))
-> Bool -> IO (Handle, CommunicationHandle)
createCommunicationPipe (a, a) -> (a, a)
forall a. a -> a
forall a. (a, a) -> (a, a)
id Bool
False
    -- safe choice: passAsyncHandleToChild = False, in case the child cannot
    -- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
    -- expert users can invoke createCommunicationPipe from
    -- System.Process.CommunicationHandle.Internals if they are sure that the
    -- child process they will communicate with supports async I/O on Windows

-- | Create a pipe @(theyRead,weWrite)@ that the current process can write to,
-- and whose read end can be passed to a child process in order to send data to it.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createTheyReadWeWritePipe
  :: IO (CommunicationHandle, Handle)
createTheyReadWeWritePipe :: IO (CommunicationHandle, Handle)
createTheyReadWeWritePipe =
  (Handle, CommunicationHandle) -> (CommunicationHandle, Handle)
forall {b} {a}. (b, a) -> (a, b)
sw ((Handle, CommunicationHandle) -> (CommunicationHandle, Handle))
-> IO (Handle, CommunicationHandle)
-> IO (CommunicationHandle, Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. (a, a) -> (a, a))
-> Bool -> IO (Handle, CommunicationHandle)
createCommunicationPipe (a, a) -> (a, a)
forall a. (a, a) -> (a, a)
forall {b} {a}. (b, a) -> (a, b)
sw Bool
False
    -- safe choice: passAsyncHandleToChild = False, in case the child cannot
    -- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
    -- expert users can invoke createCommunicationPipe from
    -- System.Process.CommunicationHandle.Internals if they are sure that the
    -- child process they will communicate with supports async I/O on Windows
  where
    sw :: (b, a) -> (a, b)
sw (b
a,a
b) = (a
b,b
a)

--------------------------------------------------------------------------------

-- | A version of 'readCreateProcessWithExitCode' that communicates with the
-- child process through a pair of 'CommunicationHandle's.
--
-- Example usage:
--
-- > readCreateProcessWithExitCodeCommunicationHandle
-- >   (\(chTheyRead, chTheyWrite) -> proc "child-exe" [show chTheyRead, show chTheyWrite])
-- >   (\ hWeRead -> hGetContents hWeRead)
-- >   (\ hWeWrite -> hPut hWeWrite "xyz")
--
-- where @child-exe@ is a separate executable that is implemented as:
--
-- > main = do
-- >   [chRead, chWrite] <- getArgs
-- >   hRead  <- openCommunicationHandleRead  $ read chRead
-- >   hWrite <- openCommunicationHandleWrite $ read chWrite
-- >   input <- hGetContents hRead
-- >   hPut hWrite $ someFn input
-- >   hClose hWrite
--
-- @since 1.6.20.0
readCreateProcessWithExitCodeCommunicationHandle
  :: NFData a
  => ((CommunicationHandle, CommunicationHandle) -> CreateProcess)
    -- ^ Process to spawn, given a @(read, write)@ pair of
    -- 'CommunicationHandle's that are inherited by the spawned process
  -> (Handle -> IO a)
    -- ^ read action
  -> (Handle -> IO ())
    -- ^ write action
  -> IO (ExitCode, a)
readCreateProcessWithExitCodeCommunicationHandle :: forall a.
NFData a =>
((CommunicationHandle, CommunicationHandle) -> CreateProcess)
-> (Handle -> IO a) -> (Handle -> IO ()) -> IO (ExitCode, a)
readCreateProcessWithExitCodeCommunicationHandle (CommunicationHandle, CommunicationHandle) -> CreateProcess
mkProg Handle -> IO a
readAction Handle -> IO ()
writeAction = do
  (CommunicationHandle
chTheyRead, Handle
hWeWrite   ) <- IO (CommunicationHandle, Handle)
createTheyReadWeWritePipe
  (Handle
hWeRead   , CommunicationHandle
chTheyWrite) <- IO (Handle, CommunicationHandle)
createWeReadTheyWritePipe
  let cp :: CreateProcess
cp = (CommunicationHandle, CommunicationHandle) -> CreateProcess
mkProg (CommunicationHandle
chTheyRead, CommunicationHandle
chTheyWrite)
  -- The following implementation parallels 'readCreateProcess'
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, a))
-> IO (ExitCode, a)
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
cp ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (ExitCode, a))
 -> IO (ExitCode, a))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, a))
-> IO (ExitCode, a)
forall a b. (a -> b) -> a -> b
$ \ Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph -> do

    -- Close the parent's references to the 'CommunicationHandle's after they
    -- have been inherited by the child (we don't want to keep pipe ends open).
    CommunicationHandle -> IO ()
closeCommunicationHandle CommunicationHandle
chTheyWrite
    CommunicationHandle -> IO ()
closeCommunicationHandle CommunicationHandle
chTheyRead

    -- Fork off a thread that waits on the output.
    a
output <- Handle -> IO a
readAction Handle
hWeRead
    IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ()
forall a. NFData a => a -> ()
rnf a
output) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ IO ()
waitOut -> do
      IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
writeAction Handle
hWeWrite
      IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
hWeWrite
      IO ()
waitOut
      Handle -> IO ()
hClose Handle
hWeRead

    ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
    (ExitCode, a) -> IO (ExitCode, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, a
output)