diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index a6032f30..e63f37e2 100644 --- a/.github/workflows/tests.yml +++ b/.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 diff --git a/.gitignore b/.gitignore index 44073d05..e71f7167 100644 --- a/.gitignore +++ b/.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 diff --git a/Setup.hs b/Setup.hs index 54f57d6f..5013a794 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,12 @@ module Main (main) where +-- Cabal import Distribution.Simple + ( defaultMainWithHooks + , autoconfUserHooks + ) + +-------------------------------------------------------------------------------- main :: IO () main = defaultMainWithHooks autoconfUserHooks diff --git a/System/Process.hs b/System/Process.hs index 79bfa74d..50447827 100644 --- a/System/Process.hs +++ b/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." diff --git a/System/Process/Common.hs b/System/Process/Common.hs index e2490d85..969ebe21 100644 --- a/System/Process/Common.hs +++ b/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 diff --git a/System/Process/CommunicationHandle.hs b/System/Process/CommunicationHandle.hs new file mode 100644 index 00000000..54f8f952 --- /dev/null +++ b/System/Process/CommunicationHandle.hs @@ -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) diff --git a/System/Process/CommunicationHandle/Internal.hsc b/System/Process/CommunicationHandle/Internal.hsc new file mode 100644 index 00000000..0d960c1e --- /dev/null +++ b/System/Process/CommunicationHandle/Internal.hsc @@ -0,0 +1,264 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +module System.Process.CommunicationHandle.Internal + ( -- * 'CommunicationHandle': a 'Handle' that can be serialised, + -- enabling inter-process communication. + CommunicationHandle(..) + , closeCommunicationHandle + -- ** Internal functions + , useCommunicationHandle + , createCommunicationPipe + ) + where + +import Control.Arrow ( first ) +import Foreign.C (CInt(..), throwErrnoIf_) +import GHC.IO.Handle (Handle()) +#if defined(mingw32_HOST_OS) +import Foreign.Marshal (alloca) +import Foreign.Ptr (ptrToWordPtr, wordPtrToPtr) +import Foreign.Storable (Storable(peek)) +import GHC.IO.Handle.FD (fdToHandle) +import GHC.IO.IOMode (IOMode(ReadMode, WriteMode)) +import System.Process.Windows (HANDLE, mkNamedPipe) +## if defined(__IO_MANAGER_WINIO__) +import Control.Exception (catch, throwIO) +import GHC.IO (onException) +import GHC.IO.Device as IODevice (close, devType) +import GHC.IO.Encoding (getLocaleEncoding) +import GHC.IO.Exception (IOException(..), IOErrorType(InvalidArgument)) +import GHC.IO.IOMode (IOMode(ReadWriteMode)) +import GHC.IO.Handle.Windows (mkHandleFromHANDLE) +import GHC.IO.SubSystem (()) +import GHC.IO.Windows.Handle (Io, NativeHandle, fromHANDLE) +import GHC.Event.Windows (associateHandle') +import System.Process.Common (rawHANDLEToHandle) +## else +import System.Process.Common (rawFdToHandle) +## endif + +#include /* for _O_BINARY */ + +#else +import System.Posix + ( Fd(..), fdToHandle + , FdOption(..), setFdOption + ) +import GHC.IO.FD (FD(fdFD)) +-- NB: we use GHC.IO.Handle.Fd.handleToFd rather than System.Posix.handleToFd, +-- as the latter flushes and closes the `Handle`, which is not the behaviour we want. +import GHC.IO.Handle.FD (handleToFd) +#endif + +##if !defined(mingw32_HOST_OS) +import System.Process.Internals + ( createPipe ) +##endif + +import GHC.IO.Handle (hClose) + +-------------------------------------------------------------------------------- +-- Communication handles. + +-- | A 'CommunicationHandle' is an operating-system specific representation +-- of a 'Handle' that can be communicated through a command-line interface. +-- +-- In a typical use case, the parent process creates a pipe, using e.g. +-- 'createWeReadTheyWritePipe' or 'createTheyReadWeWritePipe'. +-- +-- - One end of the pipe is a 'Handle', which can be read from/written to by +-- the parent process. +-- - The other end is a 'CommunicationHandle', which can be inherited by a +-- child process. A reference to the handle can be serialised (using +-- the 'Show' instance), and passed to the child process. +-- It is recommended to close the parent's reference to the 'CommunicationHandle' +-- using 'closeCommunicationHandle' after it has been inherited by the child +-- process. +-- - The child process can deserialise the 'CommunicationHandle' (using +-- the 'Read' instance), and then use 'openCommunicationHandleWrite' or +-- 'openCommunicationHandleRead' in order to retrieve a 'Handle' which it +-- can write to/read from. +-- +-- 'readCreateProcessWithExitCodeCommunicationHandle' provides a high-level API +-- to this functionality. See there for example code. +-- +-- @since 1.6.20.0 +newtype CommunicationHandle = + CommunicationHandle +##if defined(mingw32_HOST_OS) + HANDLE +##else + Fd +##endif + deriving ( Eq, Ord ) + +#if defined(mingw32_HOST_OS) +type Fd = CInt +#endif + +-- @since 1.6.20.0 +instance Show CommunicationHandle where + showsPrec p (CommunicationHandle h) = + showsPrec p +##if defined(mingw32_HOST_OS) + $ ptrToWordPtr +##endif + h + +-- @since 1.6.20.0 +instance Read CommunicationHandle where + readsPrec p str = + fmap + ( first $ CommunicationHandle +##if defined(mingw32_HOST_OS) + . wordPtrToPtr +##endif + ) $ + readsPrec p str + +-- | Internal function used to define 'openCommunicationHandleRead' and +-- openCommunicationHandleWrite. +useCommunicationHandle :: Bool -> CommunicationHandle -> IO Handle +useCommunicationHandle wantToRead (CommunicationHandle ch) = do +##if defined(__IO_MANAGER_WINIO__) + return () + associateHandleWithFallback wantToRead ch +##endif + getGhcHandle ch + +-- | Close a 'CommunicationHandle'. +-- +-- Use this to close the 'CommunicationHandle' in the parent process after +-- the 'CommunicationHandle' has been inherited by the child process. +-- +-- @since 1.6.20.0 +closeCommunicationHandle :: CommunicationHandle -> IO () +closeCommunicationHandle (CommunicationHandle ch) = + hClose =<< getGhcHandle ch + +##if defined(__IO_MANAGER_WINIO__) +-- Internal function used when associating a 'HANDLE' with the current process. +-- +-- Explanation: with WinIO, a synchronous handle cannot be associated with the +-- current process, while an asynchronous one must be associated before being usable. +-- +-- In a child process, we don't necessarily know which kind of handle we will receive, +-- so we try to associate it (in case it is an asynchronous handle). This might +-- fail (if the handle is synchronous), in which case we continue in synchronous +-- mode (without associating). +-- +-- With the current API, inheritable handles in WinIO created with mkNamedPipe +-- are synchronous, but it's best to be safe in case the child receives an +-- asynchronous handle anyway. +associateHandleWithFallback :: Bool -> HANDLE -> IO () +associateHandleWithFallback _wantToRead h = + associateHandle' h `catch` handler + where + handler :: IOError -> IO () + handler ioErr@(IOError { ioe_handle = _mbErrHandle, ioe_type = errTy, ioe_errno = mbErrNo }) + -- Catches the following error that occurs when attemping to associate + -- a HANDLE that does not have OVERLAPPING mode set: + -- + -- associateHandleWithIOCP: invalid argument (The parameter is incorrect.) + | InvalidArgument <- errTy + , Just 22 <- mbErrNo + = return () + | otherwise + = throwIO ioErr +##endif + +-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. + +#if defined(mingw32_HOST_OS) +getGhcHandle :: HANDLE -> IO Handle +getGhcHandle = + getGhcHandlePOSIX +## if defined(__IO_MANAGER_WINIO__) + getGhcHandleNative +## endif + +getGhcHandlePOSIX :: HANDLE -> IO Handle +getGhcHandlePOSIX handle = openHANDLE handle >>= fdToHandle + +openHANDLE :: HANDLE -> IO Fd +openHANDLE handle = _open_osfhandle handle (#const _O_BINARY) + +foreign import ccall "io.h _open_osfhandle" + _open_osfhandle :: HANDLE -> CInt -> IO Fd + +## if defined(__IO_MANAGER_WINIO__) +getGhcHandleNative :: HANDLE -> IO Handle +getGhcHandleNative hwnd = + do mb_codec <- fmap Just getLocaleEncoding + let iomode = ReadWriteMode + native_handle = fromHANDLE hwnd :: Io NativeHandle + hw_type <- IODevice.devType $ native_handle + mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec + `onException` IODevice.close native_handle +## endif +#else +getGhcHandle :: Fd -> IO Handle +getGhcHandle fd = fdToHandle fd +#endif + +-------------------------------------------------------------------------------- +-- Creating pipes. + +-- | Internal helper function used to define 'createWeReadTheyWritePipe' +-- and 'createTheyReadWeWritePipe' while reducing code duplication. +createCommunicationPipe + :: ( forall a. (a, a) -> (a, a) ) + -- ^ 'id' (we read, they write) or 'swap' (they read, we write) + -> Bool -- ^ whether to pass a handle supporting asynchronous I/O to the child process + -- (this flag only has an effect on Windows and when using WinIO) + -> IO (Handle, CommunicationHandle) +createCommunicationPipe swapIfTheyReadWeWrite passAsyncHandleToChild = do +##if !defined(mingw32_HOST_OS) + (ourHandle, theirHandle) <- swapIfTheyReadWeWrite <$> createPipe + -- Don't allow the child process to inherit a parent file descriptor + -- (such inheritance happens by default on Unix). + ourFD <- Fd . fdFD <$> handleToFd ourHandle + setFdOption ourFD CloseOnExec True + theirFD <- Fd . fdFD <$> handleToFd theirHandle + return (ourHandle, CommunicationHandle theirFD) +##else + trueForWinIO <- + return False +## if defined (__IO_MANAGER_WINIO__) + return True +## endif + -- On Windows, use mkNamedPipe to create the two pipe ends. + alloca $ \ pfdStdInput -> + alloca $ \ pfdStdOutput -> do + let (inheritRead, inheritWrite) = swapIfTheyReadWeWrite (False, True) + -- WinIO: + -- - make the parent pipe end overlapped, + -- - make the child end overlapped if requested, + -- Otherwise: make both pipe ends synchronous. + overlappedRead = trueForWinIO && ( passAsyncHandleToChild || not inheritRead ) + overlappedWrite = trueForWinIO && ( passAsyncHandleToChild || not inheritWrite ) + throwErrnoIf_ (==False) "mkNamedPipe" $ + mkNamedPipe + pfdStdInput inheritRead overlappedRead + pfdStdOutput inheritWrite overlappedWrite + let ((ourPtr, ourMode), (theirPtr, _theirMode)) = + swapIfTheyReadWeWrite ((pfdStdInput, ReadMode), (pfdStdOutput, WriteMode)) + ourHANDLE <- peek ourPtr + theirHANDLE <- peek theirPtr + -- With WinIO, we need to associate any handles we are going to use in + -- the current process before being able to use them. + return () +## if defined (__IO_MANAGER_WINIO__) + associateHandle' ourHANDLE +## endif + ourHandle <- +## if !defined (__IO_MANAGER_WINIO__) + ( \ fd -> rawFdToHandle fd ourMode ) =<< openHANDLE ourHANDLE +## else + -- NB: it's OK to call the following function even when we're not + -- using WinIO at runtime, so we don't use . + rawHANDLEToHandle ourHANDLE ourMode +## endif + return $ (ourHandle, CommunicationHandle theirHANDLE) +##endif diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 97ac6841..da578b6c 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -22,7 +22,7 @@ module System.Process.Internals ( ProcessHandle(..), ProcessHandle__(..), PHANDLE, closePHANDLE, mkProcessHandle, -#ifdef WINDOWS +#if defined(mingw32_HOST_OS) CGid(..), #else CGid, @@ -39,7 +39,7 @@ module System.Process.Internals ( endDelegateControlC, stopDelegateControlC, unwrapHandles, -#ifdef WINDOWS +#if defined(mingw32_HOST_OS) terminateJob, terminateJobUnsafe, waitForJobCompletion, @@ -56,11 +56,17 @@ module System.Process.Internals ( createPipe, createPipeFd, interruptProcessGroupOf, + withForkWait, + ignoreSigPipe, ) where +import Control.Concurrent +import Control.Exception (SomeException, mask, try, throwIO) +import qualified Control.Exception as C import Foreign.C import System.IO +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) import GHC.IO.Handle.FD (fdToHandle) import System.Posix.Internals (FD) @@ -68,7 +74,7 @@ import System.Process.Common #if defined(javascript_HOST_ARCH) import System.Process.JavaScript -#elif defined(WINDOWS) +#elif defined(mingw32_HOST_OS) import System.Process.Windows #else import System.Process.Posix @@ -243,3 +249,29 @@ interruptProcessGroupOf :: ProcessHandle -- ^ A process in the process group -> IO () interruptProcessGroupOf = interruptProcessGroupOfInternal + +-- | 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. +-- +-- @since 1.6.20.0 +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 + +-- | Handle any SIGPIPE errors in the given computation. +-- +-- @since 1.6.20.0 +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = C.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e \ No newline at end of file diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 86d3eb6c..ed0113de 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -18,6 +18,8 @@ module System.Process.Windows , terminateJobUnsafe , waitForJobCompletion , timeout_Infinite + , HANDLE + , mkNamedPipe ) where import System.Process.Common @@ -36,8 +38,8 @@ import System.Posix.Internals import GHC.IO.Exception ##if defined(__IO_MANAGER_WINIO__) import GHC.IO.SubSystem -import Graphics.Win32.Misc import qualified GHC.Event.Windows as Mgr +import Graphics.Win32.Misc ##endif import GHC.IO.Handle.FD import GHC.IO.Handle.Types hiding (ClosedHandle) @@ -542,17 +544,17 @@ createPipeInternalHANDLE :: IO (Handle, Handle) createPipeInternalHANDLE = alloca $ \ pfdStdInput -> alloca $ \ pfdStdOutput -> do - throwErrnoIf_ (==False) "c_mkNamedPipe" $ - c_mkNamedPipe pfdStdInput True pfdStdOutput True + throwErrnoIf_ (==False) "mkNamedPipe" $ + mkNamedPipe pfdStdInput True False pfdStdOutput True False Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput ReadMode Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput WriteMode return (hndStdInput, hndStdOutput) - -foreign import ccall "mkNamedPipe" c_mkNamedPipe :: - Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool ##endif +foreign import ccall "mkNamedPipe" mkNamedPipe :: + Ptr HANDLE -> Bool -> Bool -> Ptr HANDLE -> Bool -> Bool -> IO Bool + close' :: CInt -> IO () close' = throwErrnoIfMinus1_ "_close" . c__close diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..f99d9fad --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: ., test diff --git a/cbits/win32/runProcess.c b/cbits/win32/runProcess.c index c86c728d..5e12d5b5 100644 --- a/cbits/win32/runProcess.c +++ b/cbits/win32/runProcess.c @@ -88,8 +88,8 @@ mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, * asynchronously while anonymous pipes require blocking calls. */ BOOL -mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, - HANDLE* pHandleOut, BOOL isInheritableOut) +mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, BOOL isOverlappedIn, + HANDLE* pHandleOut, BOOL isInheritableOut, BOOL isOverlappedOut) { HANDLE hTemporaryIn = INVALID_HANDLE_VALUE; HANDLE hTemporaryOut = INVALID_HANDLE_VALUE; @@ -142,7 +142,7 @@ mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, bytes and the error ERROR_NO_DATA."[0] [0] https://devblogs.microsoft.com/oldnewthing/20110114-00/?p=11753 */ - DWORD inAttr = isInheritableIn ? 0 : FILE_FLAG_OVERLAPPED; + DWORD inAttr = isOverlappedIn ? FILE_FLAG_OVERLAPPED : 0; hTemporaryIn = CreateNamedPipeW (pipeName, PIPE_ACCESS_INBOUND | inAttr | FILE_FLAG_FIRST_PIPE_INSTANCE, @@ -153,7 +153,7 @@ mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, if (hTemporaryIn == INVALID_HANDLE_VALUE) goto fail; - /* And now create the other end using the inverse access permissions. This + /* And now open the other end, using the inverse access permissions. This will give us the read and write ends of the pipe. */ secAttr.bInheritHandle = isInheritableOut; hTemporaryOut @@ -162,9 +162,9 @@ mkNamedPipe (HANDLE* pHandleIn, BOOL isInheritableIn, FILE_SHARE_WRITE, &secAttr, OPEN_EXISTING, - isInheritableOut - ? FILE_ATTRIBUTE_NORMAL - : FILE_FLAG_OVERLAPPED, + isOverlappedOut + ? FILE_FLAG_OVERLAPPED + : FILE_ATTRIBUTE_NORMAL, NULL); if (hTemporaryOut == INVALID_HANDLE_VALUE) @@ -244,21 +244,21 @@ createJob () static inline bool setStdHandleInfo (LPHANDLE destination, HANDLE _stdhandle, LPHANDLE hStdRead, LPHANDLE hStdWrite, HANDLE defaultStd, - BOOL isInhertibleIn, BOOL isInhertibleOut, BOOL asynchronous) + BOOL isInheritableIn, BOOL isInheritableOut, BOOL asynchronous) { BOOL status; assert (destination); assert (hStdRead); assert (hStdWrite); - LPHANDLE tmpHandle = isInhertibleOut ? hStdWrite : hStdRead; + LPHANDLE tmpHandle = isInheritableOut ? hStdWrite : hStdRead; if (_stdhandle == (HANDLE)-1) { if (!asynchronous - && !mkAnonPipe(hStdRead, isInhertibleIn, hStdWrite, isInhertibleOut)) + && !mkAnonPipe(hStdRead, isInheritableIn, hStdWrite, isInheritableOut)) return false; if (asynchronous - && !mkNamedPipe(hStdRead, isInhertibleIn, hStdWrite, isInhertibleOut)) + && !mkNamedPipe(hStdRead, isInheritableIn, !isInheritableIn, hStdWrite, isInheritableOut, !isInheritableOut)) return false; *destination = *tmpHandle; } else if (_stdhandle == (HANDLE)-2) { diff --git a/changelog.md b/changelog.md index 7e055259..fcb057e7 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.20.0 *April 2024* + +* Introduce `System.Process.CommunicationHandle`, allowing for platform-independent + inter-process communication using `Handle`s. +* Expose `withForkWait` and `ignoreSigPipe` from `System.Process.Internals`. +* Define new internal functions `rawFdToHandle` and (Windows only) `rawHANDLEToHandle`, + exported from `System.Process.Common`. + ## 1.6.19.0 *April 2024* * Adjust command-line escaping logic on Windows to ensure that occurrences of diff --git a/process.cabal b/process.cabal index 0b25762f..fe37632b 100644 --- a/process.cabal +++ b/process.cabal @@ -1,14 +1,14 @@ +cabal-version: 2.4 name: process -version: 1.6.19.0 +version: 1.6.20.0 -- NOTE: Don't forget to update ./changelog.md -license: BSD3 +license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org bug-reports: https://github.com/haskell/process/issues synopsis: Process libraries category: System build-type: Configure -cabal-version: >=1.10 description: This package contains libraries for dealing with system processes. . @@ -18,9 +18,11 @@ description: read more about it at . +extra-doc-files: + changelog.md + extra-source-files: aclocal.m4 - changelog.md configure configure.ac include/HsProcessConfig.h.in @@ -52,6 +54,8 @@ library exposed-modules: System.Cmd System.Process + System.Process.CommunicationHandle + System.Process.CommunicationHandle.Internal System.Process.Internals other-modules: System.Process.Common if os(windows) @@ -90,19 +94,3 @@ library directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.6, deepseq >= 1.1 && < 1.6 - -test-suite test - default-language: Haskell2010 - hs-source-dirs: test - main-is: main.hs - type: exitcode-stdio-1.0 - -- Add otherwise redundant bounds on base since GHC's build system runs - -- `cabal check`, which mandates bounds on base. - build-depends: base >= 4 && < 5 - , bytestring - , directory - , process - ghc-options: -threaded - -with-rtsopts "-N" - if os(windows) - cpp-options: -DWINDOWS diff --git a/stack.yaml b/stack.yaml index 25614a89..7eca6c60 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,12 @@ resolver: ghc-9.2.3 + +packages: + - . + - test + +extra-deps: + - Cabal-3.6.3.0 + +allow-newer: True +allow-newer-deps: + - Cabal diff --git a/test/LICENSE b/test/LICENSE new file mode 100644 index 00000000..5343d729 --- /dev/null +++ b/test/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2024, the Haskell process developers. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/test/Setup.hs b/test/Setup.hs new file mode 100644 index 00000000..5dfa8a79 --- /dev/null +++ b/test/Setup.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -Wall #-} + +module Main (main) where + +-- Cabal +import Distribution.Simple + ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(buildHook) + ) +import Distribution.Simple.BuildPaths + ( autogenComponentModulesDir + , exeExtension + ) +import Distribution.Simple.LocalBuildInfo + ( hostPlatform + , buildDir + , withTestLBI + ) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo + , allTargetsInBuildOrder' + ) +import Distribution.Types.Component + ( Component(CExe) ) +import Distribution.Types.Executable + ( Executable(exeName) ) +import Distribution.Types.PackageDescription + ( PackageDescription ) +import Distribution.Types.TargetInfo + ( targetComponent ) +import Distribution.Types.UnqualComponentName + ( unUnqualComponentName ) + +-- directory +import System.Directory + ( createDirectoryIfMissing ) + +-- filepath +import System.FilePath + ( (), (<.>), takeDirectory ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMainWithHooks testProcessHooks + +-- The following code works around Cabal bug #9854. +-- +-- The process-tests package has an executable component named "cli-child", +-- used for testing. We want to invoke this executable when running tests; +-- however, due to the Cabal bug this executable does not get added to PATH. +-- To fix this, we create a "Test.Paths" module in a Custom setup script, +-- which contains paths to executables used for testing. +testProcessHooks :: UserHooks +testProcessHooks = + simpleUserHooks + { buildHook = \ pd lbi userHooks buildFlags -> + withTestLBI pd lbi $ \ _testSuite clbi -> do + let pathsFile = autogenComponentModulesDir lbi clbi "Test" "Paths" <.> "hs" + createDirectoryIfMissing True (takeDirectory pathsFile) + writeFile pathsFile $ unlines + [ "module Test.Paths where" + , "processInternalExes :: [(String, FilePath)]" + , "processInternalExes = " ++ show (processInternalExes pd lbi) + ] + buildHook simpleUserHooks pd lbi userHooks buildFlags + } + +processInternalExes :: PackageDescription -> LocalBuildInfo -> [(String, FilePath)] +processInternalExes pd lbi = + [ (toolName, toolLocation) + | tgt <- allTargetsInBuildOrder' pd lbi + , CExe exe <- [targetComponent tgt] + , let toolName = unUnqualComponentName $ exeName exe + toolLocation = + buildDir lbi + (toolName toolName <.> exeExtension (hostPlatform lbi)) + ] diff --git a/test/cli-child/main.hs b/test/cli-child/main.hs new file mode 100644 index 00000000..a24bdada --- /dev/null +++ b/test/cli-child/main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Main ( main ) where + +-- base +import System.Environment +import System.IO + +-- deepseq +import Control.DeepSeq + ( force ) + +-- process +import System.Process.CommunicationHandle + ( openCommunicationHandleRead + , openCommunicationHandleWrite + ) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +#endif + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case args of + [ chRead, chWrite ] -> do + childUsesWinIO <- + return False +#if defined(__IO_MANAGER_WINIO__) + return True +#endif + putStr $ unlines + [ "cli-child {" + , " childUsesWinIO: " ++ show childUsesWinIO ] + hRead <- openCommunicationHandleRead $ read chRead + hWrite <- openCommunicationHandleWrite $ read chWrite + input <- hGetContents hRead + let !output = force $ reverse input ++ "123" + hPutStr hWrite output + putStrLn "cli-child }" + hClose hWrite + _ -> error $ + unlines [ "expected two CommunicationHandle arguments, but got:" + , show args ] diff --git a/test/main.hs b/test/main.hs index b2788264..619eb031 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,28 +1,41 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + import Control.Exception -import Control.Monad (guard, unless, void) +import Control.Monad (guard, unless, void, when) import System.Exit import System.IO.Error import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Process +import System.Process.Internals (withForkWait, ignoreSigPipe) +import System.Process.CommunicationHandle import Control.Concurrent +import Control.DeepSeq import Data.Char (isDigit) import Data.IORef import Data.List (isInfixOf) import Data.Maybe (isNothing) -import System.IO (hClose, openBinaryTempFile, hGetContents) -import qualified Data.ByteString as S +import System.IO (hClose, hFlush, openBinaryTempFile, hGetContents, hPutStr) +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Char8 as S8 -import System.Directory (getTemporaryDirectory, removeFile) +import System.Directory (getTemporaryDirectory, removeFile, exeExtension) +import System.FilePath ((<.>)) import GHC.Conc.Sync (getUncaughtExceptionHandler, setUncaughtExceptionHandler) +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +#endif + +import Test.Paths ( processInternalExes ) + ifWindows :: IO () -> IO () ifWindows action | not isWindows = return () | otherwise = action isWindows :: Bool -#if WINDOWS +#if defined(mingw32_HOST_OS) isWindows = True #else isWindows = False @@ -42,6 +55,11 @@ main = do testDoubleWait testKillDoubleWait testCreateProcess + testCommunicationHandle False +#if defined(__IO_MANAGER_WINIO__) + -- With WinIO, also run the test with the child process using WinIO + testCommunicationHandle True +#endif putStrLn ">>> Tests passed successfully" run :: String -> IO () -> IO () @@ -96,13 +114,13 @@ testBinaryHandles = run "binary handles" $ do (\(fp, h) -> hClose h `finally` removeFile fp) $ \(fp, h) -> do let bs = S8.pack "hello\nthere\r\nworld\0" - S.hPut h bs + SBS.hPut h bs hClose h (Nothing, Just out, Nothing, ph) <- createProcess (proc "cat" [fp]) { std_out = CreatePipe } - res' <- S.hGetContents out + res' <- SBS.hGetContents out hClose out ec <- waitForProcess ph unless (ec == ExitSuccess) @@ -279,6 +297,41 @@ testCreateProcess = run "createProcess with cwd = Nothing" $ do Right ExitSuccess -> return () Right exitCode -> error $ "unexpected exit code: " ++ show exitCode +testCommunicationHandle :: Bool -> IO () +testCommunicationHandle childUsesWinIO = do + parentUsesWinIO <- + return False +#if defined(__IO_MANAGER_WINIO__) + return True +#endif + putStr $ unlines + [ "testCommunicationHandle {" + , "parentUsesWinIO: " ++ show parentUsesWinIO + ] + -- Workaround for Cabal bug #9854 (cli-child executable not in PATH). + let cliChild = + case lookup "cli-child" processInternalExes of + Just cliChildPath -> cliChildPath + Nothing -> "cli-child" <.> exeExtension + (ex, output) <- + readCreateProcessWithExitCodeCommunicationHandle + (\(chTheyRead, chTheyWrite) -> + let args = [show chTheyRead, show chTheyWrite] + ++ if childUsesWinIO + then ["+RTS", "--io-manager=native", "-RTS"] + else [] + in proc cliChild args) + hGetContents + (`hPutStr` "hello") + case ex of + ExitSuccess -> + if output == "olleh123" + then return () + else error $ "testCommunicationHandle: unexpected output " ++ show output + ExitFailure {} -> + error $ "testCommunicationHandle: child exited with exception " ++ show ex + putStrLn "testCommunicationHandle }" + withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory new inner = do orig <- getCurrentDirectory diff --git a/test/process-tests.cabal b/test/process-tests.cabal new file mode 100644 index 00000000..1fae173c --- /dev/null +++ b/test/process-tests.cabal @@ -0,0 +1,54 @@ +cabal-version: 2.4 +name: process-tests +version: 1.6.20.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: https://github.com/haskell/process/issues +synopsis: Testing package for the process library +category: System +build-type: Custom +description: + This package contains the testing infrastructure for the process library + +source-repository head + type: git + location: https://github.com/haskell/process.git + subdir: test + +common process-dep + build-depends: + process == 1.6.20.0 + +custom-setup + setup-depends: + base >= 4.10 && < 4.20, + directory >= 1.1 && < 1.4, + filepath >= 1.2 && < 1.6, + Cabal >= 2.4 && < 3.12, + +-- Test executable for the CommunicationHandle functionality +executable cli-child + import: process-dep + default-language: Haskell2010 + hs-source-dirs: cli-child + main-is: main.hs + build-depends: base >= 4 && < 5 + , deepseq >= 1.1 && < 1.6 + ghc-options: -threaded -rtsopts + +test-suite test + import: process-dep + default-language: Haskell2010 + hs-source-dirs: . + main-is: main.hs + type: exitcode-stdio-1.0 + build-depends: base >= 4 && < 5 + , bytestring >= 0.11 && < 0.13 + , deepseq >= 1.1 && < 1.6 + , directory >= 1.1 && < 1.4 + , filepath >= 1.2 && < 1.6 + build-tool-depends: process-tests:cli-child + ghc-options: -threaded -rtsopts -with-rtsopts "-N" + other-modules: Test.Paths + autogen-modules: Test.Paths