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.

Author: sheaf

Setup.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+-- Cabal
 import Distribution.Simple
   ( defaultMainWithHooks
   , autoconfUserHooks

System/Process.hs

@@ -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
@@ -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 )
@@ -615,28 +616,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
 

System/Process/Common.hs

@@ -19,6 +19,7 @@ module System.Process.Common
     , mbFd
     , mbPipe
     , pfdToHandle
+    , rawFdToHandle
 
 -- Avoid a warning on Windows
 #if defined(mingw32_HOST_OS)
@@ -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
@@ -270,8 +272,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()
@@ -299,11 +304,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