Skip to content

Commit

Permalink
An API for inter-process communication via Handles
Browse files Browse the repository at this point in the history
This commit adds the System.Process.CommunicationHandle module, which
provides the cross-platform CommunicationHandle abstraction which allows
Handles to be passed to child processes for inter-process communication.

A high-level API is provided by the function
`readCreateProcessWithExitCodeCommunicationHandle`, which can be
consulted for further details about how the functionality is meant to be
used.

To test this functionality, we created a new "cli-child" executable
component to the process-tests package. To work around Cabal bug #9854,
it was necessary to change the build-type of the package to `Custom`, in
order to make the "cli-child" executable visible when running the test-suite.
The custom Setup.hs script contains more details about the problem.
  • Loading branch information
sheaf committed Apr 10, 2024
1 parent 13ede6d commit 3624c42
Show file tree
Hide file tree
Showing 14 changed files with 712 additions and 66 deletions.
1 change: 1 addition & 0 deletions Setup.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
module Main (main) where

-- Cabal
import Distribution.Simple
( defaultMainWithHooks
, autoconfUserHooks
Expand Down
31 changes: 5 additions & 26 deletions System/Process.hs
Original file line number Diff line number Diff line change
Expand Up @@ -89,11 +89,11 @@ import System.Process.Internals

import Control.Concurrent
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, mask
import Control.Exception (
#if !defined(javascript_HOST_ARCH)
, allowInterrupt
allowInterrupt,
#endif
, bracket, try, throwIO)
bracket)
import qualified Control.Exception as C
import Control.Monad
import Data.Maybe
Expand All @@ -111,7 +111,8 @@ import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId)
import System.Posix.Process (getProcessID)
import System.Posix.Types (CPid (..))
#endif
import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )

import GHC.IO.Exception ( ioException, IOErrorType(..) )

#if defined(wasm32_HOST_ARCH)
import GHC.IO.Exception ( unsupportedOperation )
Expand Down Expand Up @@ -616,28 +617,6 @@ readCreateProcessWithExitCode cp input = do
(_,Nothing,_) -> error "readCreateProcessWithExitCode: Failed to get a stdout handle."
(_,_,Nothing) -> error "readCreateProcessWithExitCode: Failed to get a stderr handle."

-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return
restore (body wait) `C.onException` killThread tid

ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = C.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e

-- ----------------------------------------------------------------------------
-- showCommandForUser

Expand Down
28 changes: 18 additions & 10 deletions System/Process/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ module System.Process.Common
, mbFd
, mbPipe
, pfdToHandle
, rawFdToHandle

-- Avoid a warning on Windows
#if defined(mingw32_HOST_OS)
Expand All @@ -32,14 +33,15 @@ module System.Process.Common
, HANDLE
, mbHANDLE
, mbPipeHANDLE
, rawHANDLEToHandle
#endif
) where

import Control.Concurrent
import Control.Exception
import Data.String
import Data.String ( IsString(..) )
import Foreign.Ptr
import Foreign.Storable
import Foreign.Storable ( Storable(peek) )

import System.Posix.Internals
import GHC.IO.Exception
Expand Down Expand Up @@ -278,8 +280,11 @@ mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)
mbPipe _std _pfd _mode = return Nothing

pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle pfd mode = do
fd <- peek pfd
pfdToHandle pfd mode =
rawFdToHandle mode =<< peek pfd

rawFdToHandle :: IOMode -> FD -> IO Handle
rawFdToHandle mode fd = do
let filepath = "fd:" ++ show fd
(fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
(Just (Stream,0,0)) -- avoid calling fstat()
Expand Down Expand Up @@ -307,11 +312,14 @@ mbHANDLE _std NoStream = return $ intPtrToPtr (-2)
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl

mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
mbPipeHANDLE CreatePipe pfd mode =
do raw_handle <- peek pfd
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
ident = "hwnd:" ++ show raw_handle
enc <- fmap Just getLocaleEncoding
Just <$> mkHandleFromHANDLE hwnd Stream ident mode enc
mbPipeHANDLE CreatePipe pfd mode =
Just <$> ( rawHANDLEToHandle mode =<< peek pfd )
mbPipeHANDLE _std _pfd _mode = return Nothing

rawHANDLEToHandle :: IOMode -> HANDLE -> IO Handle
rawHANDLEToHandle mode raw_handle = do
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
ident = "hwnd:" ++ show raw_handle
enc <- getLocaleEncoding
mkHandleFromHANDLE hwnd Stream ident mode (Just enc)
#endif
142 changes: 142 additions & 0 deletions System/Process/CommunicationHandle.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,142 @@
{-# 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.
--
-- @since 1.6.20.0
openCommunicationHandleRead :: CommunicationHandle -> IO Handle
openCommunicationHandleRead = useCommunicationHandle True

-- | Turn the 'CommunicationHandle' into a 'Handle' that can be written to
-- in the current process.
--
-- @since 1.6.20.0
openCommunicationHandleWrite :: CommunicationHandle -> IO Handle
openCommunicationHandleWrite = useCommunicationHandle 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.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createWeReadTheyWritePipe
:: IO (Handle, CommunicationHandle)
createWeReadTheyWritePipe =
createCommunicationPipe id 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.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createTheyReadWeWritePipe
:: IO (CommunicationHandle, Handle)
createTheyReadWeWritePipe =
sw <$> createCommunicationPipe sw 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 (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 mkProg readAction writeAction = do
(chTheyRead, hWeWrite ) <- createTheyReadWeWritePipe
(hWeRead , chTheyWrite) <- createWeReadTheyWritePipe
let cp = mkProg (chTheyRead, chTheyWrite)
-- The following implementation parallels 'readCreateProcess'
withCreateProcess cp $ \ _ _ _ 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).
closeCommunicationHandle chTheyWrite
closeCommunicationHandle chTheyRead

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

ex <- waitForProcess ph
return (ex, output)

0 comments on commit 3624c42

Please sign in to comment.