Skip to content

Commit a6af24e

Browse files
sheafsheaf
committed
An API for inter-process communication via Handles
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.
1 parent 13ede6d commit a6af24e

File tree

14 files changed

+717
-69
lines changed

14 files changed

+717
-69
lines changed

‎Setup.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Main (main) where
22

3+
-- Cabal
34
import Distribution.Simple
45
( defaultMainWithHooks
56
, autoconfUserHooks

‎System/Process.hs‎

Lines changed: 5 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -89,11 +89,11 @@ import System.Process.Internals
8989

9090
import Control.Concurrent
9191
import Control.DeepSeq (rnf)
92-
import Control.Exception (SomeException, mask
92+
import Control.Exception (
9393
#if !defined(javascript_HOST_ARCH)
94-
, allowInterrupt
94+
allowInterrupt,
9595
#endif
96-
, bracket, try, throwIO)
96+
bracket)
9797
import qualified Control.Exception as C
9898
import Control.Monad
9999
import Data.Maybe
@@ -111,7 +111,8 @@ import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId)
111111
import System.Posix.Process (getProcessID)
112112
import System.Posix.Types (CPid (..))
113113
#endif
114-
import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )
114+
115+
import GHC.IO.Exception ( ioException, IOErrorType(..) )
115116

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

619-
-- | Fork a thread while doing something else, but kill it if there's an
620-
-- exception.
621-
--
622-
-- This is important in the cases above because we want to kill the thread
623-
-- that is holding the Handle lock, because when we clean up the process we
624-
-- try to close that handle, which could otherwise deadlock.
625-
--
626-
withForkWait :: IO () -> (IO () -> IO a) -> IO a
627-
withForkWait async body = do
628-
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
629-
mask $ \restore -> do
630-
tid <- forkIO $ try (restore async) >>= putMVar waitVar
631-
let wait = takeMVar waitVar >>= either throwIO return
632-
restore (body wait) `C.onException` killThread tid
633-
634-
ignoreSigPipe :: IO () -> IO ()
635-
ignoreSigPipe = C.handle $ \e -> case e of
636-
IOError { ioe_type = ResourceVanished
637-
, ioe_errno = Just ioe }
638-
| Errno ioe == ePIPE -> return ()
639-
_ -> throwIO e
640-
641620
-- ----------------------------------------------------------------------------
642621
-- showCommandForUser
643622

‎System/Process/Common.hs‎

Lines changed: 27 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module System.Process.Common
1919
, mbFd
2020
, mbPipe
2121
, pfdToHandle
22+
, rawFdToHandle
2223

2324
-- Avoid a warning on Windows
2425
#if defined(mingw32_HOST_OS)
@@ -27,19 +28,22 @@ module System.Process.Common
2728
, CGid
2829
#endif
2930

30-
-- WINIO is only available on GHC 8.12 and up.
31-
#if defined(__IO_MANAGER_WINIO__)
31+
#if defined(mingw32_HOST_OS)
3232
, HANDLE
33+
-- WINIO is only available on GHC 9.0 and up.
34+
# if defined(__IO_MANAGER_WINIO__)
3335
, mbHANDLE
3436
, mbPipeHANDLE
37+
, rawHANDLEToHandle
38+
# endif
3539
#endif
3640
) where
3741

3842
import Control.Concurrent
3943
import Control.Exception
40-
import Data.String
44+
import Data.String ( IsString(..) )
4145
import Foreign.Ptr
42-
import Foreign.Storable
46+
import Foreign.Storable ( Storable(peek) )
4347

4448
import System.Posix.Internals
4549
import GHC.IO.Exception
@@ -278,8 +282,11 @@ mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)
278282
mbPipe _std _pfd _mode = return Nothing
279283

280284
pfdToHandle :: Ptr FD -> IOMode -> IO Handle
281-
pfdToHandle pfd mode = do
282-
fd <- peek pfd
285+
pfdToHandle pfd mode =
286+
( \ fd -> rawFdToHandle fd mode ) =<< peek pfd
287+
288+
rawFdToHandle :: FD -> IOMode -> IO Handle
289+
rawFdToHandle fd mode = do
283290
let filepath = "fd:" ++ show fd
284291
(fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
285292
(Just (Stream,0,0)) -- avoid calling fstat()
@@ -293,6 +300,11 @@ pfdToHandle pfd mode = do
293300
#endif
294301
mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)
295302

303+
304+
#if defined(mingw32_HOST_OS) && !defined(__IO_MANAGER_WINIO__)
305+
type HANDLE = Ptr ()
306+
#endif
307+
296308
#if defined(__IO_MANAGER_WINIO__)
297309
-- It is not completely safe to pass the values -1 and -2 as HANDLE as it's an
298310
-- unsigned type. -1 additionally is also the value for INVALID_HANDLE. However
@@ -307,11 +319,14 @@ mbHANDLE _std NoStream = return $ intPtrToPtr (-2)
307319
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl
308320

309321
mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
310-
mbPipeHANDLE CreatePipe pfd mode =
311-
do raw_handle <- peek pfd
312-
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
313-
ident = "hwnd:" ++ show raw_handle
314-
enc <- fmap Just getLocaleEncoding
315-
Just <$> mkHandleFromHANDLE hwnd Stream ident mode enc
322+
mbPipeHANDLE CreatePipe pfd mode =
323+
Just <$> ( ( \ hANDLE -> rawHANDLEToHandle hANDLE mode ) =<< peek pfd )
316324
mbPipeHANDLE _std _pfd _mode = return Nothing
325+
326+
rawHANDLEToHandle :: HANDLE -> IOMode-> IO Handle
327+
rawHANDLEToHandle raw_handle mode = do
328+
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
329+
ident = "hwnd:" ++ show raw_handle
330+
enc <- getLocaleEncoding
331+
mkHandleFromHANDLE hwnd Stream ident mode (Just enc)
317332
#endif

‎System/Process/CommunicationHandle.hs‎

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
4+
module System.Process.CommunicationHandle
5+
( -- * 'CommunicationHandle': a 'Handle' that can be serialised,
6+
-- enabling inter-process communication.
7+
CommunicationHandle
8+
-- NB: opaque, as the representation depends on the operating system
9+
, openCommunicationHandleRead
10+
, openCommunicationHandleWrite
11+
, closeCommunicationHandle
12+
-- * Creating 'CommunicationHandle's to communicate with
13+
-- a child process
14+
, createWeReadTheyWritePipe
15+
, createTheyReadWeWritePipe
16+
-- * High-level API
17+
, readCreateProcessWithExitCodeCommunicationHandle
18+
)
19+
where
20+
21+
import GHC.IO.Handle (Handle)
22+
23+
import System.Process.CommunicationHandle.Internal
24+
import System.Process.Internals
25+
( CreateProcess(..), ignoreSigPipe, withForkWait )
26+
import System.Process
27+
( withCreateProcess, waitForProcess )
28+
29+
import GHC.IO (evaluate)
30+
import GHC.IO.Handle (hClose)
31+
import System.Exit (ExitCode)
32+
33+
import Control.DeepSeq (NFData, rnf)
34+
35+
--------------------------------------------------------------------------------
36+
-- Communication handles.
37+
38+
-- | Turn the 'CommunicationHandle' into a 'Handle' that can be read from
39+
-- in the current process.
40+
--
41+
-- @since 1.6.20.0
42+
openCommunicationHandleRead :: CommunicationHandle -> IO Handle
43+
openCommunicationHandleRead = useCommunicationHandle True
44+
45+
-- | Turn the 'CommunicationHandle' into a 'Handle' that can be written to
46+
-- in the current process.
47+
--
48+
-- @since 1.6.20.0
49+
openCommunicationHandleWrite :: CommunicationHandle -> IO Handle
50+
openCommunicationHandleWrite = useCommunicationHandle False
51+
52+
--------------------------------------------------------------------------------
53+
-- Creating pipes.
54+
55+
-- | Create a pipe @(weRead,theyWrite)@ that the current process can read from,
56+
-- and whose write end can be passed to a child process in order to receive data from it.
57+
--
58+
-- See 'CommunicationHandle'.
59+
--
60+
-- @since 1.6.20.0
61+
createWeReadTheyWritePipe
62+
:: IO (Handle, CommunicationHandle)
63+
createWeReadTheyWritePipe =
64+
createCommunicationPipe id False
65+
-- safe choice: passAsyncHandleToChild = False, in case the child cannot
66+
-- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
67+
-- expert users can invoke createCommunicationPipe from
68+
-- System.Process.CommunicationHandle.Internals if they are sure that the
69+
-- child process they will communicate with supports async I/O on Windows
70+
71+
-- | Create a pipe @(theyRead,weWrite)@ that the current process can write to,
72+
-- and whose read end can be passed to a child process in order to send data to it.
73+
--
74+
-- See 'CommunicationHandle'.
75+
--
76+
-- @since 1.6.20.0
77+
createTheyReadWeWritePipe
78+
:: IO (CommunicationHandle, Handle)
79+
createTheyReadWeWritePipe =
80+
sw <$> createCommunicationPipe sw False
81+
-- safe choice: passAsyncHandleToChild = False, in case the child cannot
82+
-- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
83+
-- expert users can invoke createCommunicationPipe from
84+
-- System.Process.CommunicationHandle.Internals if they are sure that the
85+
-- child process they will communicate with supports async I/O on Windows
86+
where
87+
sw (a,b) = (b,a)
88+
89+
--------------------------------------------------------------------------------
90+
91+
-- | A version of 'readCreateProcessWithExitCode' that communicates with the
92+
-- child process through a pair of 'CommunicationHandle's.
93+
--
94+
-- Example usage:
95+
--
96+
-- > readCreateProcessWithExitCodeCommunicationHandle
97+
-- > (\(chTheyRead, chTheyWrite) -> proc "child-exe" [show chTheyRead, show chTheyWrite])
98+
-- > (\ hWeRead -> hGetContents hWeRead)
99+
-- > (\ hWeWrite -> hPut hWeWrite "xyz")
100+
--
101+
-- where @child-exe@ is a separate executable that is implemented as:
102+
--
103+
-- > main = do
104+
-- > [chRead, chWrite] <- getArgs
105+
-- > hRead <- openCommunicationHandleRead $ read chRead
106+
-- > hWrite <- openCommunicationHandleWrite $ read chWrite
107+
-- > input <- hGetContents hRead
108+
-- > hPut hWrite $ someFn input
109+
-- > hClose hWrite
110+
--
111+
-- @since 1.6.20.0
112+
readCreateProcessWithExitCodeCommunicationHandle
113+
:: NFData a
114+
=> ((CommunicationHandle, CommunicationHandle) -> CreateProcess)
115+
-- ^ Process to spawn, given a @(read, write)@ pair of
116+
-- 'CommunicationHandle's that are inherited by the spawned process
117+
-> (Handle -> IO a)
118+
-- ^ read action
119+
-> (Handle -> IO ())
120+
-- ^ write action
121+
-> IO (ExitCode, a)
122+
readCreateProcessWithExitCodeCommunicationHandle mkProg readAction writeAction = do
123+
(chTheyRead, hWeWrite ) <- createTheyReadWeWritePipe
124+
(hWeRead , chTheyWrite) <- createWeReadTheyWritePipe
125+
let cp = mkProg (chTheyRead, chTheyWrite)
126+
-- The following implementation parallels 'readCreateProcess'
127+
withCreateProcess cp $ \ _ _ _ ph -> do
128+
-- Close the parent's references to the 'CommunicationHandle's after they
129+
-- have been inherited by the child (we don't want to keep pipe ends open).
130+
closeCommunicationHandle chTheyWrite
131+
closeCommunicationHandle chTheyRead
132+
133+
-- Fork off a thread that waits on the output.
134+
output <- readAction hWeRead
135+
withForkWait (evaluate $ rnf output) $ \ waitOut -> do
136+
ignoreSigPipe $ writeAction hWeWrite
137+
ignoreSigPipe $ hClose hWeWrite
138+
waitOut
139+
hClose hWeRead
140+
141+
ex <- waitForProcess ph
142+
return (ex, output)

0 commit comments

Comments
 (0)