process 1.6.19.0 → 1.6.20.0
raw patch · 11 files changed
+525/−378 lines, 11 filesdep −bytestringdep −processdep ~basedep ~directorysetup-changed
Dependencies removed: bytestring, process
Dependency ranges changed: base, directory
Files
- Setup.hs +6/−0
- System/Process.hs +10/−32
- System/Process/Common.hs +30/−15
- System/Process/CommunicationHandle.hs +142/−0
- System/Process/CommunicationHandle/Internal.hsc +264/−0
- System/Process/Internals.hs +35/−3
- System/Process/Windows.hsc +8/−6
- cbits/win32/runProcess.c +11/−11
- changelog.md +11/−0
- process.cabal +8/−20
- test/main.hs +0/−291
Setup.hs view
@@ -1,6 +1,12 @@ module Main (main) where +-- Cabal import Distribution.Simple+ ( defaultMainWithHooks+ , autoconfUserHooks+ )++-------------------------------------------------------------------------------- main :: IO () main = defaultMainWithHooks autoconfUserHooks
System/Process.hs view
@@ -89,11 +89,11 @@ 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 @@ #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 @@ -- @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 @@ (_,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 @@ 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 = #if defined(javascript_HOST_ARCH) getCurrentProcessId-#elif defined(WINDOWS)+#elif defined(mingw32_HOST_OS) getCurrentProcessId #else getProcessID@@ -743,7 +721,7 @@ 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 @@ 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 view
@@ -19,27 +19,31 @@ , 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 @@ -- 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 @@ #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 _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 @@ #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 (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
+ System/Process/CommunicationHandle.hs view
@@ -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)
+ System/Process/CommunicationHandle/Internal.hsc view
@@ -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 <fcntl.h> /* 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
System/Process/Internals.hs view
@@ -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 @@ endDelegateControlC, stopDelegateControlC, unwrapHandles,-#ifdef WINDOWS+#if defined(mingw32_HOST_OS) terminateJob, terminateJobUnsafe, waitForJobCompletion,@@ -56,11 +56,17 @@ 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 @@ #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 @@ :: 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
System/Process/Windows.hsc view
@@ -18,6 +18,8 @@ , terminateJobUnsafe , waitForJobCompletion , timeout_Infinite+ , HANDLE+ , mkNamedPipe ) where import System.Process.Common@@ -36,8 +38,8 @@ 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,16 +544,16 @@ 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
cbits/win32/runProcess.c view
@@ -88,8 +88,8 @@ * 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 @@ 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 @@ 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 @@ 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 @@ 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) {
changelog.md view
@@ -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@@ -7,6 +15,9 @@ properly escaped in arguments passed to `.bat` and `.cmd` processes. This addresses [HSEC-2024-0003](https://github.com/haskell/security-advisories/tree/main/advisories/hackage/process/HSEC-2024-0003.md).+* Fix double-closing of stdin/stdout/stderr fds with POSIX `fork/exec` backend.+ [#306](https://github.com/haskell/process/issues/306)+* Add support for `posix_spawn_file_actions_addchdir_np` ## 1.6.18.0 *September 2023*
process.cabal view
@@ -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 @@ read more about it at <https://github.com/fpco/typed-process/#readme>. +extra-doc-files:+ changelog.md+ extra-source-files: aclocal.m4- changelog.md configure configure.ac include/HsProcessConfig.h.in@@ -52,6 +54,8 @@ 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 @@ 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
− test/main.hs
@@ -1,291 +0,0 @@-{-# LANGUAGE CPP #-}-import Control.Exception-import Control.Monad (guard, unless, void)-import System.Exit-import System.IO.Error-import System.Directory (getCurrentDirectory, setCurrentDirectory)-import System.Process-import Control.Concurrent-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 qualified Data.ByteString.Char8 as S8-import System.Directory (getTemporaryDirectory, removeFile)-import GHC.Conc.Sync (getUncaughtExceptionHandler, setUncaughtExceptionHandler)--ifWindows :: IO () -> IO ()-ifWindows action- | not isWindows = return ()- | otherwise = action--isWindows :: Bool-#if WINDOWS-isWindows = True-#else-isWindows = False-#endif--main :: IO ()-main = do- testDoesNotExist- testModifiers- testSubdirectories- testBinaryHandles- testMultithreadedWait- testInterruptMaskedWait- testGetPid- testReadProcess- testInterruptWith- testDoubleWait- testKillDoubleWait- testCreateProcess- putStrLn ">>> Tests passed successfully"--run :: String -> IO () -> IO ()-run label test = do- putStrLn $ ">>> Running: " ++ label- test--testDoesNotExist :: IO ()-testDoesNotExist = run "non-existent executable" $ do- res <- handle (return . Left . isDoesNotExistError) $ do- (_, _, _, ph) <- createProcess (proc "definitelydoesnotexist" [])- { close_fds = True- }- fmap Right $ waitForProcess ph- case res of- Left True -> return ()- _ -> error $ show res--testModifiers :: IO ()-testModifiers = do- let test name modifier = run ("modifier " ++ name) $ do- (_, _, _, ph) <- createProcess- $ modifier $ proc "echo" ["hello", "world"]- ec <- waitForProcess ph- unless (ec == ExitSuccess)- $ error $ "echo returned: " ++ show ec-- test "vanilla" id-- -- FIXME need to debug this in the future on Windows- unless isWindows $ test "detach_console" $ \cp -> cp { detach_console = True }-- test "create_new_console" $ \cp -> cp { create_new_console = True }- test "new_session" $ \cp -> cp { new_session = True }--testSubdirectories :: IO ()-testSubdirectories = ifWindows $ run "subdirectories" $ do- withCurrentDirectory "exes" $ do- res1 <- readCreateProcess (proc "./echo.bat" []) ""- unless ("parent" `isInfixOf` res1 && not ("child" `isInfixOf` res1)) $ error $- "echo.bat with cwd failed: " ++ show res1-- res2 <- readCreateProcess (proc "./echo.bat" []) { cwd = Just "subdir" } ""- unless ("child" `isInfixOf` res2 && not ("parent" `isInfixOf` res2)) $ error $- "echo.bat with cwd failed: " ++ show res2--testBinaryHandles :: IO ()-testBinaryHandles = run "binary handles" $ do- tmpDir <- getTemporaryDirectory- bracket- (openBinaryTempFile tmpDir "process-binary-test.bin")- (\(fp, h) -> hClose h `finally` removeFile fp)- $ \(fp, h) -> do- let bs = S8.pack "hello\nthere\r\nworld\0"- S.hPut h bs- hClose h-- (Nothing, Just out, Nothing, ph) <- createProcess (proc "cat" [fp])- { std_out = CreatePipe- }- res' <- S.hGetContents out- hClose out- ec <- waitForProcess ph- unless (ec == ExitSuccess)- $ error $ "Unexpected exit code " ++ show ec- unless (bs == res')- $ error $ "Unexpected result: " ++ show res'--testMultithreadedWait :: IO ()-testMultithreadedWait = run "multithreaded wait" $ do- (_, _, _, p) <- createProcess (proc "sleep" ["0.1"])- me1 <- newEmptyMVar- _ <- forkIO . void $ waitForProcess p >>= putMVar me1- -- check for race / deadlock between waitForProcess and getProcessExitCode- e3 <- getProcessExitCode p- e2 <- waitForProcess p- e1 <- readMVar me1- unless (isNothing e3)- $ error $ "unexpected exit " ++ show e3- unless (e1 == ExitSuccess && e2 == ExitSuccess)- $ error "sleep exited with non-zero exit code!"--testInterruptMaskedWait :: IO ()-testInterruptMaskedWait = run "interrupt masked wait" $ do- (_, _, _, p) <- createProcess (proc "sleep" ["1.0"])- mec <- newEmptyMVar- tid <- mask_ . forkIO $- (waitForProcess p >>= putMVar mec . Just)- `catchThreadKilled` putMVar mec Nothing- killThread tid- eec <- takeMVar mec- case eec of- Nothing -> return ()- Just ec ->- if isWindows- then putStrLn "FIXME ignoring known failure on Windows"- else error $ "waitForProcess not interrupted: sleep exited with " ++ show ec--testGetPid :: IO ()-testGetPid = run "getPid" $ do- (_, Just out, _, p) <-- if isWindows- then createProcess $ (proc "sh" ["-c", "z=$$; cat /proc/$z/winpid"]) {std_out = CreatePipe}- else createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe}- pid <- getPid p- line <- hGetContents out- putStrLn $ " queried PID: " ++ show pid- putStrLn $ " PID reported by stdout: " ++ show line- _ <- waitForProcess p- hClose out- let numStdoutPid = read (takeWhile isDigit line) :: Pid- unless (Just numStdoutPid == pid) $- if isWindows- then putStrLn "FIXME ignoring known failure on Windows"- else error "subprocess reported unexpected PID"--testReadProcess :: IO ()-testReadProcess = run "readProcess" $ do- output <- readProcess "echo" ["hello", "world"] ""- unless (output == "hello world\n") $- error $ "unexpected output, got: " ++ output---- | Test that withCreateProcess doesn't throw exceptions besides--- the expected UserInterrupt when the child process is interrupted--- by Ctrl-C.-testInterruptWith :: IO ()-testInterruptWith = unless isWindows $ run "interrupt withCreateProcess" $ do- mpid <- newEmptyMVar- forkIO $ do- pid <- takeMVar mpid- void $ readProcess "kill" ["-INT", show pid] ""-- -- collect unhandled exceptions in any threads (specifically- -- the asynchronous 'waitForProcess' call from 'cleanupProcess')- es <- collectExceptions $ do- let sleep = (proc "sleep" ["10"]) { delegate_ctlc = True }- res <- try $ withCreateProcess sleep $ \_ _ _ p -> do- Just pid <- getPid p- putMVar mpid pid- waitForProcess p- unless (res == Left UserInterrupt) $- error $ "expected UserInterrupt, got " ++ show res-- unless (null es) $- error $ "uncaught exceptions: " ++ show es-- where- collectExceptions action = do- oldHandler <- getUncaughtExceptionHandler- flip finally (setUncaughtExceptionHandler oldHandler) $ do- exceptions <- newIORef ([] :: [SomeException])- setUncaughtExceptionHandler (\e -> atomicModifyIORef exceptions $ \es -> (e:es, ()))- action- threadDelay 1000 -- give some time for threads to finish- readIORef exceptions---- Test that we can wait without exception twice, if the process exited on its own.-testDoubleWait :: IO ()-testDoubleWait = run "run process, then wait twice" $ do- let sleep = (proc "sleep" ["0"])- (_, _, _, p) <- createProcess sleep- res <- try $ waitForProcess p- case res of- Left e -> error $ "waitForProcess threw: " ++ show (e :: SomeException)- Right ExitSuccess -> return ()- Right exitCode -> error $ "unexpected exit code: " ++ show exitCode-- res2 <- try $ waitForProcess p- case res2 of- Left e -> error $ "second waitForProcess threw: " ++ show (e :: SomeException)- Right ExitSuccess -> return ()- Right exitCode -> error $ "unexpected exit code: " ++ show exitCode---- Test that we can wait without exception twice, if the process was killed.-testKillDoubleWait :: IO ()-testKillDoubleWait = unless isWindows $ do- run "terminate process, then wait twice (delegate_ctlc = False)" $ runTest "TERM" False- run "terminate process, then wait twice (delegate_ctlc = True)" $ runTest "TERM" True- run "interrupt process, then wait twice (delegate_ctlc = False)" $ runTest "INT" False- run "interrupt process, then wait twice (delegate_ctlc = True)" $ runTest "INT" True- where- runTest sig delegate = do- let sleep = (proc "sleep" ["10"])- (_, _, _, p) <- createProcess sleep { delegate_ctlc = delegate }- Just pid <- getPid p- void $ readProcess "kill" ["-" ++ sig, show pid] ""-- res <- try $ waitForProcess p- checkFirst sig delegate res-- res' <- try $ waitForProcess p- checkSecond sig delegate res'-- checkFirst :: String -> Bool -> Either SomeException ExitCode -> IO ()- checkFirst sig delegate res = case (sig, delegate) of- ("INT", True) -> case res of- Left e -> case fromException e of- Just UserInterrupt -> putStrLn "result ok"- Nothing -> error $ "expected UserInterrupt, got " ++ show e- Right _ -> error $ "expected exception, got " ++ show res- _ -> case res of- Left e -> error $ "waitForProcess threw: " ++ show e- Right ExitSuccess -> error "expected failure"- _ -> putStrLn "result ok"-- checkSecond :: String -> Bool -> Either SomeException ExitCode -> IO ()- checkSecond sig delegate res = case (sig, delegate) of- ("INT", True) -> checkFirst "INT" False res- _ -> checkFirst sig delegate res---- Test that createProcess doesn't segfault on Mac with a cwd of Nothing-testCreateProcess :: IO ()-testCreateProcess = run "createProcess with cwd = Nothing" $ do- let env = CreateProcess- { child_group = Nothing- , child_user = Nothing- , close_fds = False- , cmdspec = RawCommand "env" []- , create_group = True- , create_new_console = False- , cwd = Nothing- , delegate_ctlc = False- , detach_console = False- , env = Just [("PATH", "/bin:/usr/bin")]- , new_session = False- , std_err = Inherit- , std_in = Inherit- , std_out = Inherit- , use_process_jobs = False- }- (_, _, _, p) <- createProcess env- res <- try $ waitForProcess p- case res of- Left e -> error $ "waitForProcess threw: " ++ show (e :: SomeException)- Right ExitSuccess -> return ()- Right exitCode -> error $ "unexpected exit code: " ++ show exitCode--withCurrentDirectory :: FilePath -> IO a -> IO a-withCurrentDirectory new inner = do- orig <- getCurrentDirectory- bracket_- (setCurrentDirectory new)- (setCurrentDirectory orig)- inner--catchThreadKilled :: IO a -> IO a -> IO a-catchThreadKilled f g = catchJust (\e -> guard (e == ThreadKilled)) f (\() -> g)