diff --git a/Setup.hs b/Setup.hs index 54f57d6f..54a4a16f 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,82 @@ +{-# OPTIONS_GHC -Wall #-} + module Main (main) where +-- Cabal import Distribution.Simple + ( defaultMainWithHooks + , autoconfUserHooks + , 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 autoconfUserHooks +main = defaultMainWithHooks processHooks + +-- The following code works around Cabal bug #9854. +-- +-- The process 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. +processHooks :: UserHooks +processHooks = + defaultConfigureHooks + { 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 defaultConfigureHooks pd lbi userHooks buildFlags + } + +defaultConfigureHooks :: UserHooks +defaultConfigureHooks = autoconfUserHooks + +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/System/Process.hs b/System/Process.hs index 18892893..5bd37af9 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 @@ -112,7 +112,7 @@ 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 ) @@ -616,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 diff --git a/System/Process/CommunicationHandle.hsc b/System/Process/CommunicationHandle.hsc new file mode 100644 index 00000000..c1f3a29e --- /dev/null +++ b/System/Process/CommunicationHandle.hsc @@ -0,0 +1,350 @@ +{-# 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 + , useCommunicationHandle + , closeCommunicationHandle + -- * Creating 'CommunicationHandle's to communicate with + -- a child process + , createWeReadTheyWritePipe + , createTheyReadWeWritePipe + -- * High-level API + , readCreateProcessWithExitCodeCommunicationHandle + ) + where + +import Control.Arrow ( first ) +import Foreign.C +import GHC.IO.Handle (Handle()) +#if defined(mingw32_HOST_OS) +import Foreign.Ptr +import GHC.IO (onException) +import GHC.Windows (HANDLE) +import GHC.IO.Handle.FD (fdToHandle) +import GHC.IO.Device as IODevice +import GHC.IO.Encoding (getLocaleEncoding) +import GHC.IO.IOMode +import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle()) +## if defined(__IO_MANAGER_WINIO__) +import Foreign.Marshal +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE, mkHandleFromHANDLE) +import GHC.Event.Windows (associateHandle') +import System.Process.Common (StdStream(CreatePipe), mbPipeHANDLE) +## endif + +#include /* for _O_BINARY */ + +#else +import System.Posix + ( Fd(..), fdToHandle + , FdOption(..), setFdOption + ) +import GHC.IO.FD (FD(fdFD)) +import GHC.IO.Handle.FD (handleToFd) +#endif + +import System.Process.Internals + ( CreateProcess(..), ignoreSigPipe, withForkWait, +##if defined(mingw32_HOST_OS) + createPipeFd, +##else + createPipe +##endif + ) +import System.Process + ( withCreateProcess, waitForProcess ) + +import GHC.IO ( evaluate ) +import GHC.IO.Handle ( hClose ) +import System.Exit + +import Control.DeepSeq ( NFData, rnf ) + +-------------------------------------------------------------------------------- +-- 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 'useCommunicationHandle' +-- 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.19.0 +newtype CommunicationHandle = + CommunicationHandle +##if defined(mingw32_HOST_OS) + HANDLE +##else + Fd +##endif + deriving ( Eq, Ord ) + +-- @since 1.6.19.0 +instance Show CommunicationHandle where + showsPrec p (CommunicationHandle h) = + showsPrec p +##if defined(mingw32_HOST_OS) + $ ptrToWordPtr +##endif + h + +-- @since 1.6.19.0 +instance Read CommunicationHandle where + readsPrec p str = + fmap + ( first $ CommunicationHandle +##if defined(mingw32_HOST_OS) + . wordPtrToPtr +##endif + ) $ + readsPrec p str + +-- | Turn the 'CommunicationHandle' into a 'Handle' that can be used +-- in the current process. +-- +-- @since 1.6.19.0 +useCommunicationHandle :: CommunicationHandle -> IO Handle +useCommunicationHandle (CommunicationHandle ch) = do +##if defined(mingw32_HOST_OS) && defined(__IO_MANAGER_WINIO__) + -- register the handle we received with the I/O manager + return () + -- NB: we don't associate in the child process, + -- because inheritable handles in WinIO are always synchronous + -- and thus should not be associated manually. + -- associateHandle' 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.19.0 +closeCommunicationHandle :: CommunicationHandle -> IO () +closeCommunicationHandle (CommunicationHandle ch) = + hClose =<< getGhcHandle ch + +-- | 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 getGhcHandleNative + +getGhcHandlePOSIX :: HANDLE -> IO Handle +getGhcHandlePOSIX handle = + _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle + +foreign import ccall "io.h _open_osfhandle" + _open_osfhandle :: HANDLE -> CInt -> IO CInt + +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 +#else +getGhcHandle :: Fd -> IO Handle +getGhcHandle fd = fdToHandle fd +#endif + +-------------------------------------------------------------------------------- +-- 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.19.0 +createWeReadTheyWritePipe :: IO (Handle, CommunicationHandle) +createWeReadTheyWritePipe = create_pipe id + +-- | 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.19.0 +createTheyReadWeWritePipe :: IO (CommunicationHandle, Handle) +createTheyReadWeWritePipe = sw <$> create_pipe sw + where + sw (a,b) = (b,a) + +-- | Internal helper function used to define 'createWeReadTheyWritePipe' +-- and 'createTheyReadWeWritePipe' while reducing code duplication. +create_pipe + :: ( forall a. (a, a) -> (a, a) ) + -> IO (Handle, CommunicationHandle) +create_pipe oursTheirs = do + + -- On Windows: + -- - with WinIO, use pipes. + -- - without WinIO, use FDs. + -- On POSIX: use pipes. + + res@(hUs, _chThem) <- +##if defined(mingw32_HOST_OS) + usingFDs +## if defined(__IO_MANAGER_WINIO__) + usingPipes +## endif +##else + usingPipes +##endif + associateToCurrentProcess hUs + return res + where +##if defined(mingw32_HOST_OS) + usingFDs :: IO (Handle, CommunicationHandle) + usingFDs = do + (fdRead, fdWrite) <- createPipeFd + let (fdUs, fdThem) = oursTheirs (fdRead, fdWrite) + chThem <- + CommunicationHandle <$> + _get_osfhandle fdThem + hUs <- fdToHandle fdUs `onException` c__close fdUs + return (hUs, chThem) +##endif +##if !defined(mingw32_HOST_OS) || defined(__IO_MANAGER_WINIO__) + usingPipes :: IO (Handle, CommunicationHandle) + usingPipes = do + (hUs, hThem) <- createPipeCompat oursTheirs + chThem <- + CommunicationHandle <$> +## if defined(__IO_MANAGER_WINIO__) + handleToHANDLE hThem +## else +-- NB: here 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. + (Fd . fdFD <$> handleToFd hThem) +## endif + return (hUs, chThem) +##endif + +createPipeCompat :: ( forall a. (a, a) -> (a, a) ) + -> IO (Handle, Handle) +createPipeCompat swap = +##if !defined(__IO_MANAGER_WINIO__) + swap <$> createPipe +##else + alloca $ \ pfdStdInput -> + alloca $ \ pfdStdOutput -> do + throwErrnoIf_ (==False) "c_mkNamedPipe" $ + -- Create one end to be inheritable and the other + -- to be inheritable, which ensures the un-inheritable part + -- can be properly associated with the parent process. + c_mkNamedPipe pfdStdInput inheritRead pfdStdOutput inheritWrite + Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput ReadMode + Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput WriteMode + return $ swap (hndStdInput, hndStdOutput) + where (inheritRead, inheritWrite) = swap (False, True) + +foreign import ccall "mkNamedPipe" c_mkNamedPipe :: + Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool +##endif + +-- | Associate the 'Handle' to the current process. This is an internal +-- operation that ensures the handle can be properly read from/written to, +-- within the current process. +associateToCurrentProcess :: Handle -> IO () +associateToCurrentProcess _h = do +##if !defined(mingw32_HOST_OS) + fd <- Fd . fdFD <$> handleToFd _h + -- Don't allow the child process to inherit a parent file descriptor + -- (such inheritance happens by default on Unix). + setFdOption fd CloseOnExec True +##else + return () +## if defined (__IO_MANAGER_WINIO__) + -- With WinIO, we need to associate any handles we are going to use in + -- the current process before being able to use them. + (associateHandle' =<< handleToHANDLE _h) +## endif +##endif + +##if defined(mingw32_HOST_OS) +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO HANDLE + +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt +##endif + +-------------------------------------------------------------------------------- + +-- | 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 <- useCommunicationHandle $ read chRead +-- > hWrite <- useCommunicationHandle $ read chWrite +-- > input <- hGetContents hRead +-- > hPut hWrite $ someFn input +-- > hClose hWrite +-- +-- @since 1.6.19.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/Internals.hs b/System/Process/Internals.hs index 97ac6841..5505e897 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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) @@ -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.19.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.19.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/changelog.md b/changelog.md index 38991d75..407b4f49 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.19.0 *March 2024* + +* Introduce `System.Process.CommunicationHandle`, allowing for platform-independent + inter-process communication using `Handle`s. + ## 1.6.18.0 *September 2023* * Fix deadlock when waiting for process completion and process jobs [#273](https://github.com/haskell/process/issues/273) diff --git a/process.cabal b/process.cabal index d59fadbc..40a273ff 100644 --- a/process.cabal +++ b/process.cabal @@ -1,14 +1,14 @@ +cabal-version: 2.4 name: process -version: 1.6.18.0 +version: 1.6.19.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 +build-type: Custom description: This package contains libraries for dealing with system processes. . @@ -39,6 +39,13 @@ source-repository head type: git location: https://github.com/haskell/process.git +custom-setup + setup-depends: + base >= 4.10 && < 4.20, + directory >= 1.1 && < 1.4, + filepath >= 1.2 && < 1.6, + Cabal >= 2.4 && < 3.12, + library default-language: Haskell2010 other-extensions: @@ -52,6 +59,7 @@ library exposed-modules: System.Cmd System.Process + System.Process.CommunicationHandle System.Process.Internals other-modules: System.Process.Common if os(windows) @@ -84,13 +92,23 @@ library runProcess.h processFlags.h - ghc-options: -Wall + ghc-options: -Wall -rtsopts build-depends: base >= 4.10 && < 4.20, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.6, deepseq >= 1.1 && < 1.6 +-- Test executable for the CommunicationHandle functionality +executable cli-child + default-language: Haskell2010 + hs-source-dirs: test/cli-child + main-is: main.hs + build-depends: base >= 4 && < 5 + , deepseq + , process + ghc-options: -threaded -rtsopts + test-suite test default-language: Haskell2010 hs-source-dirs: test @@ -100,9 +118,14 @@ test-suite test -- `cabal check`, which mandates bounds on base. build-depends: base >= 4 && < 5 , bytestring + , deepseq , directory , process - ghc-options: -threaded - -with-rtsopts "-N" + -- The autogenerated Test.Paths module works around Cabal bug #9854. + -- See the custom Setup for details. + other-modules: Test.Paths + autogen-modules: Test.Paths + build-tool-depends: process:cli-child + ghc-options: -threaded -rtsopts -with-rtsopts "-N" if os(windows) cpp-options: -DWINDOWS diff --git a/test/cli-child/main.hs b/test/cli-child/main.hs new file mode 100644 index 00000000..4cd53c80 --- /dev/null +++ b/test/cli-child/main.hs @@ -0,0 +1,42 @@ +{-# 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 + ( useCommunicationHandle ) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +#endif + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case args of + [ chRead, chWrite ] -> do + putStrLn "Starting cli-child" +#if defined(__IO_MANAGER_WINIO__) + putStrLn "cli-child not using WinIO" putStrLn "cli-child using WinIO" +#endif + hRead <- useCommunicationHandle $ read chRead + hWrite <- useCommunicationHandle $ read chWrite + putStrLn "child stdout 1" + input <- hGetContents hRead + putStrLn "child stdout 2" + let !output = force $ reverse (take 5 input) ++ "123" + putStrLn "child stdout 3" + hPutStr hWrite output + putStrLn "child stdout 4" + hClose hWrite + _ -> error "expected two CommunicationHandle arguments" diff --git a/test/main.hs b/test/main.hs index b2788264..85944321 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,21 +1,29 @@ {-# 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 GHC.Conc.Sync (getUncaughtExceptionHandler, setUncaughtExceptionHandler) +import Test.Paths ( processInternalExes ) + ifWindows :: IO () -> IO () ifWindows action | not isWindows = return () @@ -42,6 +50,9 @@ main = do testDoubleWait testKillDoubleWait testCreateProcess + testCommunicationHandle False + when isWindows $ + testCommunicationHandle True putStrLn ">>> Tests passed successfully" run :: String -> IO () -> IO () @@ -96,13 +107,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 +290,30 @@ testCreateProcess = run "createProcess with cwd = Nothing" $ do Right ExitSuccess -> return () Right exitCode -> error $ "unexpected exit code: " ++ show exitCode +testCommunicationHandle :: Bool -> IO () +testCommunicationHandle useWinIO = do + putStrLn $ "Starting testCommunicationHandle, WinIO = " ++ show useWinIO + let cliChild = case lookup "cli-child" processInternalExes of + Nothing -> "cli-child" + Just cliChildPath -> cliChildPath + (ex, output) <- + readCreateProcessWithExitCodeCommunicationHandle + (\(chTheyRead, chTheyWrite) -> + let args = [show chTheyRead, show chTheyWrite] + ++ if useWinIO 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 $ "Finished testCommunicationHandle, WinIO = " ++ show useWinIO + withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory new inner = do orig <- getCurrentDirectory