Add CommunicationHandle, an API for inter-process communication via Handles

.github/workflows/tests.yml

@@ -3,45 +3,114 @@ name: Tests
 on:
     pull_request:
     push:
-        branches:
-        - master
+      branches:
+        - '**'
 
 jobs:
   build:
-    name: CI
+    name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }}
     runs-on: ${{ matrix.os }}
     strategy:
       fail-fast: false
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
-        args:
-        - "--resolver ghc-9.8.1"
-        - "--resolver ghc-9.6.3"
-        - "--resolver ghc-9.4.7"
-        - "--resolver ghc-9.2.8"
-        - "--resolver ghc-9.0.1"
-        - "--resolver ghc-8.10.4"
-        - "--resolver ghc-8.8.4"
-        - "--resolver ghc-8.6.5"
-        - "--resolver ghc-8.4.4"
-        - "--resolver ghc-8.2.2"
+        ghc-version:
+          - 'latest'
+          - '9.8'
+          - '9.6'
+          - '9.4'
+          - '9.2'
+          - '9.0'
+          - '8.10'
+          - '8.8'
+          - '8.6'
+          - '8.4'
+          - '8.2'
+
+        exclude:
+          # Exclude GHC 8.2 on Windows (GHC bug: undefined reference to `__stdio_common_vswprintf_s')
+          - os: windows-latest
+            ghc-version: '8.2'
 
     steps:
-      - name: Clone project
-        uses: actions/checkout@v4
+      - uses: actions/checkout@v4
+
+      - name: Set up GHC ${{ matrix.ghc-version }}
+        uses: haskell-actions/setup@v2
+        id: setup
+        with:
+          ghc-version: ${{ matrix.ghc-version }}
+          # Defaults, added for clarity:
+          cabal-version: 'latest'
+          cabal-update: true
+
+      - name: Set up autotools (Windows)
+        if: ${{ runner.os == 'Windows' }}
+        uses: msys2/setup-msys2@v2
+        with:
+          update: true
+          install: >-
+            autotools
+
+      - name: Run autoreconf (Windows)
+        if: ${{ runner.os == 'Windows' }}
+        run: autoreconf -i
+        shell: "msys2 {0}"
 
-      - name: Build and run tests
-        shell: bash
+      - name: Run autoreconf (Linux & Mac)
+        if: ${{ runner.os != 'Windows' }}
+        run: autoreconf -i
+
+      - name: Configure the build
         run: |
-            set -ex
-            stack upgrade
-            stack --version
-            if [[ "${{ runner.os }}" = 'Windows' ]]
-            then
-              # Looks like a bug in Stack, this shouldn't break things
-              ls C:/ProgramData/Chocolatey/bin/
-              rm -rf C:/ProgramData/Chocolatey/bin/ghc*
-              stack ${{ matrix.args }} exec pacman -- --sync --refresh --noconfirm autoconf
-            fi
-            stack test --bench --no-run-benchmarks --haddock --no-terminal ${{ matrix.args }}
-            stack sdist --test-tarball
+          cabal configure --enable-tests --enable-benchmarks --disable-documentation
+          cabal build all --dry-run
+        # The last step generates dist-newstyle/cache/plan.json for the cache key.
+
+      - name: Restore cached dependencies
+        uses: actions/cache/restore@v3
+        id: cache
+        env:
+          key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}
+        with:
+          path: ${{ steps.setup.outputs.cabal-store }}
+          key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}
+          restore-keys: ${{ env.key }}-
+
+      - name: Install dependencies
+        # If we had an exact cache hit, the dependencies will be up to date.
+        if: steps.cache.outputs.cache-hit != 'true'
+        run: cabal build process --only-dependencies
+
+      # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.
+      - name: Save cached dependencies
+        uses: actions/cache/save@v3
+        # If we had an exact cache hit, trying to save the cache would error because of key clash.
+        if: steps.cache.outputs.cache-hit != 'true'
+        with:
+          path: ${{ steps.setup.outputs.cabal-store }}
+          key: ${{ steps.cache.outputs.cache-primary-key }}
+
+      - name: Build
+        run: cabal build process
+
+      - name: Run tests
+        run: cabal run process-tests:test
+
+        # On Windows and with GHC >= 9.0, re-run the test-suite using WinIO.
+      - name: Re-run tests with WinIO (Windows && GHC >= 9.0)
+        if: ${{ runner.os == 'Windows' && matrix.ghc-version >= '9.0' }}
+        run: cabal run process-tests:test -- +RTS --io-manager=native -RTS
+
+      - name: Source dist
+        run: cabal sdist all --ignore-project
+
+      - name: Build documentation
+        run: cabal haddock process
+
+      - name: Check process.cabal
+        run: cabal check
+
+      - name: Check process-tests.cabal
+        working-directory: ./test
+        run: cabal check

.gitignore

@@ -1,10 +1,11 @@
-/.cabal-sandbox/
-/cabal.project.local
-/cabal.sandbox.config
-/dist/
-/dist-newstyle/
-/.stack-work/
+**/.cabal-sandbox/
+**/cabal.project.local
+**/cabal.sandbox.config
+**/dist/
+**/dist-newstyle/
+**/.stack-work/
 *.swp
+stack.yaml.lock
 
 # Specific generated files
 GNUmakefile

Setup.hs

@@ -1,6 +1,12 @@
 module Main (main) where
 
+-- Cabal
 import Distribution.Simple
+  ( defaultMainWithHooks
+  , autoconfUserHooks
+  )
+
+--------------------------------------------------------------------------------
 
 main :: IO ()
 main = 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
@@ -105,14 +105,14 @@ import System.IO.Error (mkIOError, ioeSetErrorString)
 
 #if defined(javascript_HOST_ARCH)
 import System.Process.JavaScript(getProcessId, getCurrentProcessId)
-#elif defined(WINDOWS)
+#elif defined(mingw32_HOST_OS)
 import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId)
 #else
 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 )
@@ -126,7 +126,7 @@ import System.IO.Error
 -- @since 1.6.3.0
 #if defined(javascript_HOST_ARCH)
 type Pid = Int
-#elif defined(WINDOWS)
+#elif defined(mingw32_HOST_OS)
 type Pid = ProcessId
 #else
 type Pid = CPid
@@ -617,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
 
@@ -668,7 +646,7 @@ getPid (ProcessHandle mh _ _) = do
     OpenHandle h -> do
       pid <- getProcessId h
       return $ Just pid
-#elif defined(WINDOWS)
+#elif defined(mingw32_HOST_OS)
     OpenHandle h -> do
       pid <- getProcessId h
       return $ Just pid
@@ -691,7 +669,7 @@ getCurrentPid :: IO Pid
 getCurrentPid =
 #if defined(javascript_HOST_ARCH)
     getCurrentProcessId
-#elif defined(WINDOWS)
+#elif defined(mingw32_HOST_OS)
     getCurrentProcessId
 #else
     getProcessID
@@ -743,7 +721,7 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
         when (was_open && delegating_ctlc) $
           endDelegateControlC e
         return e'
-#if defined(WINDOWS)
+#if defined(mingw32_HOST_OS)
     OpenExtHandle h job -> do
         -- First wait for completion of the job...
         waitForJobCompletion job
@@ -872,7 +850,7 @@ terminateProcess ph = do
   withProcessHandle ph $ \p_ ->
     case p_ of
       ClosedHandle  _ -> return ()
-#if defined(WINDOWS)
+#if defined(mingw32_HOST_OS)
       OpenExtHandle{} -> terminateJobUnsafe p_ 1 >> return ()
 #else
       OpenExtHandle{} -> error "terminateProcess with OpenExtHandle should not happen on POSIX."

System/Process/Common.hs

@@ -19,27 +19,31 @@ module System.Process.Common
     , mbFd
     , mbPipe
     , pfdToHandle
+    , rawFdToHandle
 
 -- Avoid a warning on Windows
-#ifdef WINDOWS
+#if defined(mingw32_HOST_OS)
     , CGid (..)
 #else
     , CGid
 #endif
 
--- WINIO is only available on GHC 8.12 and up.
-#if defined(__IO_MANAGER_WINIO__)
+#if defined(mingw32_HOST_OS)
     , HANDLE
+-- WINIO is only available on GHC 9.0 and up.
+#  if defined(__IO_MANAGER_WINIO__)
     , mbHANDLE
     , mbPipeHANDLE
+    , rawHANDLEToHandle
+#  endif
 #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
@@ -63,7 +67,7 @@ import GHC.JS.Prim (JSVal)
 
 -- We do a minimal amount of CPP here to provide uniform data types across
 -- Windows and POSIX.
-#ifdef WINDOWS
+#if defined(mingw32_HOST_OS)
 import Data.Word (Word32)
 import System.Win32.DebugApi (PHANDLE)
 #if defined(__IO_MANAGER_WINIO__)
@@ -75,7 +79,7 @@ import System.Posix.Types
 
 #if defined(javascript_HOST_ARCH)
 type PHANDLE = JSVal
-#elif defined(WINDOWS)
+#elif defined(mingw32_HOST_OS)
 -- Define some missing types for Windows compatibility. Note that these values
 -- will never actually be used, as the setuid/setgid system calls are not
 -- applicable on Windows. No value of this type will ever exist.
@@ -278,8 +282,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 =
+  ( \ fd -> rawFdToHandle fd mode ) =<< peek pfd
+
+rawFdToHandle :: FD -> IOMode -> IO Handle
+rawFdToHandle fd mode = do
   let filepath = "fd:" ++ show fd
   (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
                        (Just (Stream,0,0)) -- avoid calling fstat()
@@ -293,6 +300,11 @@ pfdToHandle pfd mode = do
 #endif
   mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)
 
+
+#if defined(mingw32_HOST_OS) && !defined(__IO_MANAGER_WINIO__)
+type HANDLE = Ptr ()
+#endif
+
 #if defined(__IO_MANAGER_WINIO__)
 -- It is not completely safe to pass the values -1 and -2 as HANDLE as it's an
 -- unsigned type. -1 additionally is also the value for INVALID_HANDLE.  However
@@ -307,11 +319,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 <$> ( ( \ hANDLE -> rawHANDLEToHandle hANDLE mode ) =<< peek pfd )
 mbPipeHANDLE _std      _pfd _mode = return Nothing
+
+rawHANDLEToHandle :: HANDLE -> IOMode-> IO Handle
+rawHANDLEToHandle raw_handle mode  = do
+  let hwnd  = fromHANDLE raw_handle :: Io NativeHandle
+      ident = "hwnd:" ++ show raw_handle
+  enc <- getLocaleEncoding
+  mkHandleFromHANDLE hwnd Stream ident mode (Just enc)
 #endif