process 1.6.18.0 → 1.6.30.0
raw patch · 20 files changed
Files
- Setup.hs +6/−0
- System/Process.hs +112/−65
- System/Process/Common.hs +40/−16
- System/Process/CommunicationHandle.hs +155/−0
- System/Process/CommunicationHandle/Internal.hsc +311/−0
- System/Process/Environment/OsString.hs +41/−0
- System/Process/Internals.hs +40/−8
- System/Process/Posix.hs +3/−1
- System/Process/Windows.hsc +57/−9
- cbits/posix/common.h +2/−0
- cbits/posix/fork_exec.c +5/−12
- cbits/posix/posix_spawn.c +28/−5
- cbits/posix/runProcess.c +12/−3
- cbits/win32/runProcess.c +11/−11
- changelog.md +81/−0
- configure +6/−0
- configure.ac +1/−1
- include/HsProcessConfig.h.in +4/−0
- process.cabal +35/−25
- 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
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE LambdaCase #-} #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} #else@@ -31,23 +32,57 @@ module System.Process ( -- * Running sub-processes++ -- ** General interface to process creation++ -- | @createProcess@ and @createProcess_@ are general interfaces+ -- to process creation. To start with you might instead want to use+ -- one of the [simpler process creation functions](#g:simpler)+ -- below.+ createProcess, createProcess_,++ -- ** Creating a @CreateProcess@++ -- | Once you have a @CreateProcess@ you can launch it with+ -- 'createProcess' or one of the [simpler process creation+ -- functions](#g:simpler).+ shell, proc,++ -- ** @CreateProcess@ and associated types+ CreateProcess(..), CmdSpec(..), StdStream(..), ProcessHandle, - -- ** Simpler functions for common tasks+ -- * Simpler functions for common tasks #simpler#++ -- ** Call, the simplest way of launching a process++ callCreateProcess, callProcess, callCommand,++ -- ** Spawn, obtaining a @ProcessHandle@+ spawnProcess, spawnCommand,++ -- ** Read, passing @stdin@ and obtaining @stdout@+ readCreateProcess, readProcess,++ -- ** Read with exit code, passing @stdin@, obtaining exit code, @stdout@ and @stderr@+ readCreateProcessWithExitCode, readProcessWithExitCode,++ -- ** Other+ withCreateProcess, cleanupProcess, @@ -57,6 +92,9 @@ getPid, getCurrentPid, + -- ** Secure process creation on Windows+ -- $windows-mitigations+ -- ** Control-C handling on Unix -- $ctlc-handling @@ -89,11 +127,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 +143,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 +164,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@@ -334,43 +372,47 @@ -- ---------------------------------------------------------------------------- -- callProcess/callCommand --- | Creates a new process to run the specified command with the given--- arguments, and wait for it to finish. If the command returns a non-zero--- exit code, an exception is raised.+-- | Creates a new process from the provided `CreateProcess`, and wait for it+-- to finish. If the process returns a non-zero exit code, an exception is+-- raised. -- -- If an asynchronous exception is thrown to the thread executing--- @callProcess@, the forked process will be terminated and--- @callProcess@ will wait (block) until the process has been+-- @callCreateProcess@, the forked process will be terminated and+-- @callCreateProcess@ will wait (block) until the process has been -- terminated. --+-- @since TODO+callCreateProcess :: CreateProcess -> IO ()+callCreateProcess = callCreateProcess_ "callCreateProcess"++-- | \"@callProcess cmd args@\" is a shorthand for+-- \"@'callCreateProcess' ('proc' cmd args)@\".+-- -- @since 1.2.0.0 callProcess :: FilePath -> [String] -> IO ()-callProcess cmd args = do- exit_code <- withCreateProcess_ "callProcess"- (proc cmd args) { delegate_ctlc = True } $ \_ _ _ p ->- waitForProcess p- case exit_code of- ExitSuccess -> return ()- ExitFailure r -> processFailedException "callProcess" cmd args r+callProcess cmd = callCreateProcess_ "callProcess" . proc cmd --- | Creates a new process to run the specified shell command. If the--- command returns a non-zero exit code, an exception is raised.------ If an asynchronous exception is thrown to the thread executing--- @callCommand@, the forked process will be terminated and--- @callCommand@ will wait (block) until the process has been--- terminated.+-- | \"@callCommand cmd@\" is a shorthand for \"@'callCreateProcess'+-- ('shell' cmd)@\". -- -- @since 1.2.0.0 callCommand :: String -> IO ()-callCommand cmd = do- exit_code <- withCreateProcess_ "callCommand"- (shell cmd) { delegate_ctlc = True } $ \_ _ _ p ->+callCommand = callCreateProcess_ "callCommand" . shell++callCreateProcess_ :: String -> CreateProcess -> IO ()+callCreateProcess_ fun command = do+ exit_code <- withCreateProcess_ fun+ command { delegate_ctlc = True } $ \_ _ _ p -> waitForProcess p case exit_code of ExitSuccess -> return ()- ExitFailure r -> processFailedException "callCommand" cmd [] r+ ExitFailure r -> processFailed fun (cmdspec command) r +processFailed :: String -> CmdSpec -> Int -> IO a+processFailed fun = \ case+ ShellCommand cmd -> processFailedException fun cmd []+ RawCommand cmd args -> processFailedException fun cmd args+ processFailedException :: String -> String -> [String] -> Int -> IO a processFailedException fun cmd args exit_code = ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++@@ -380,6 +422,39 @@ -- ----------------------------------------------------------------------------+-- Secure process creation on Windows++-- $windows-migitations+--+-- In general it is strongly advised that any untrusted user input be validated before+-- being passed to a subprocess. One must be especially careful on Windows due to the+-- crude nature of the platform's argument passing scheme. Specifically, unlike POSIX+-- platforms, Windows treats the command-line not as a sequence of arguments but rather+-- as a single string. It is therefore the responsibility of the called process to tokenize+-- this string into distinct arguments.+--+-- While various programs on Windows tend to differ in their precise argument splitting+-- behavior, the scheme used by @process@'s 'RawCommand' 'CmdSpec' should work for+-- most reasonable programs. If you find that 'RawCommand' doesn't provide+-- the behavior you need, it is recommended to instead compose your command-line+-- manually and rather using the 'shell' 'CmdSpec'.+--+-- Additionally, the idiosyncratic escaping and string interpolation behavior of+-- the Windows @cmd.exe@ command interpreter is known to introduce considerable+-- complication to secure process creation. For this reason, @process@ implements+-- specific argument escaping logic when the executable's file extension suggests+-- that it is a batch file (e.g. @.bat@ or @.cmd@). However, this is not a+-- completely reliable mitigation as Windows will also silently execute batch files+-- when starting executables lacking a file extension (e.g. @callProcess "hello" []@+-- when a @hello.bat@ is present in @PATH@). For this reason, users are encouraged to+-- specify the file extension of invoked executables where possible, especially+-- when untrusted input is involved.+--+-- Users passed untrusted input to subprocesses on Windows are encouraged to review+-- <https://flatt.tech/research/posts/batbadbut-you-cant-securely-execute-commands-on-windows/>+-- for guidance on how to safely navigate these waters.++-- ---------------------------------------------------------------------------- -- Control-C handling on Unix -- $ctlc-handling@@ -478,7 +553,8 @@ -- -- * The command to run, which must be in the $PATH, or an absolute or relative path ----- * A list of separate command line arguments to the program+-- * A list of separate command line arguments to the program. See 'RawCommand' for+-- further discussion of Windows semantics. -- -- * A string to pass on standard input to the forked process. --@@ -537,14 +613,7 @@ case ex of ExitSuccess -> return output- ExitFailure r -> processFailedException "readCreateProcess" cmd args r- where- cmd = case cp of- CreateProcess { cmdspec = ShellCommand sc } -> sc- CreateProcess { cmdspec = RawCommand fp _ } -> fp- args = case cp of- CreateProcess { cmdspec = ShellCommand _ } -> []- CreateProcess { cmdspec = RawCommand _ args' } -> args'+ ExitFailure r -> processFailed "readCreateProcess" (cmdspec cp) r -- | @readProcessWithExitCode@ is like 'readProcess' but with two differences:@@ -616,28 +685,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 @@ -667,7 +714,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@@ -690,7 +737,7 @@ getCurrentPid = #if defined(javascript_HOST_ARCH) getCurrentProcessId-#elif defined(WINDOWS)+#elif defined(mingw32_HOST_OS) getCurrentProcessId #else getProcessID@@ -742,7 +789,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@@ -871,7 +918,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.@@ -93,7 +97,8 @@ std_in :: StdStream, -- ^ How to determine stdin std_out :: StdStream, -- ^ How to determine stdout std_err :: StdStream, -- ^ How to determine stderr- close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. XXX verify what happens with fds in nodejs child processes+ -- XXX verify what happens with fds in nodejs child processes+ close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. create_group :: Bool, -- ^ Create a new process group. On JavaScript this also creates a new session. delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details). --@@ -160,6 +165,14 @@ -- see the -- <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365527%28v=vs.85%29.aspx documentation> -- for the Windows @SearchPath@ API.+ --+ -- Windows does not have a mechanism for passing multiple arguments.+ -- When using @RawCommand@ on Windows, the command line is serialised+ -- into a string, with arguments quoted separately. Command line+ -- parsing is up individual programs, so the default behaviour may+ -- not work for some programs. If you are not getting the desired+ -- results, construct the command line yourself and use 'ShellCommand'.+ -- deriving (Show, Eq) @@ -270,8 +283,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()@@ -285,6 +301,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@@ -299,11 +320,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,155 @@+{-# 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.+--+-- The returned 'Handle' does not have any finalizers attached to it;+-- use 'hClose' to close it.+--+-- @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.+--+-- The returned 'Handle' does not have any finalizers attached to it;+-- use 'hClose' to close it.+--+-- @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.+--+-- The returned 'Handle' does not have any finalizers attached to it;+-- use 'hClose' to close 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.+--+-- The returned 'Handle' does not have any finalizers attached to it;+-- use 'hClose' to close 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,311 @@+{-# 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 GHC.IO.Handle (Handle, hClose)+#if defined(mingw32_HOST_OS)+import Foreign.C (CInt(..), throwErrnoIf_)+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 GHC.IO.FD+ ( mkFD, setNonBlockingMode )+import GHC.IO.Handle+ ( noNewlineTranslation )+#if MIN_VERSION_base(4,16,0)+import GHC.IO.Handle.Internals+ ( mkFileHandleNoFinalizer )+#else+import GHC.IO.IOMode+ ( IOMode(..) )+import GHC.IO.Handle.Types+ ( HandleType(..) )+import GHC.IO.Handle.Internals+ ( mkHandle )+#endif+import System.Posix+ ( Fd(..)+ , FdOption(..), setFdOption+ )+import System.Posix.Internals+ ( fdGetMode )+import System.Process.Internals+ ( createPipeFd )+#endif++--------------------------------------------------------------------------------+-- Communication handles.++-- | A 'CommunicationHandle' is an abstraction over operating-system specific+-- internal representation of a 'Handle', which 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 fdint) = do+ iomode <- fdGetMode fdint+ (fd0, _) <- mkFD fdint iomode Nothing False True+ -- The following copies over 'mkHandleFromFDNoFinalizer'+ fd <- setNonBlockingMode fd0 True+ let fd_str = "<file descriptor: " ++ show fd ++ ">"+# if MIN_VERSION_base(4,16,0)+ mkFileHandleNoFinalizer fd fd_str iomode Nothing noNewlineTranslation+# else+ mkHandle fd fd_str (ioModeToHandleType iomode) True Nothing noNewlineTranslation+ Nothing Nothing++ioModeToHandleType :: IOMode -> HandleType+ioModeToHandleType mode =+ case mode of+ ReadMode -> ReadHandle+ WriteMode -> WriteHandle+ ReadWriteMode -> ReadWriteHandle+ AppendMode -> AppendHandle+# endif+#endif++--------------------------------------------------------------------------------+-- Creating pipes.++-- | Internal helper function used to define 'createWeReadTheyWritePipe'+-- and 'createTheyReadWeWritePipe' while reducing code duplication.+--+-- The returned 'Handle' does not have any finalizers attached to it;+-- use 'hClose' to close it.+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)+ -- NB: it's important to use 'createPipeFd' here.+ --+ -- Were we to instead use 'createPipe', we would create a Handle for both pipe+ -- ends, including the end we pass to the child.+ -- Such Handle would have a finalizer which closes the underlying file descriptor.+ -- However, we will already close the FD after it is inherited by the child.+ -- This could lead to the following scenario:+ --+ -- - the parent creates a new pipe, e.g. pipe2([7,8]),+ -- - the parent spawns a child process, and lets FD 8 be inherited by the child,+ -- - the parent closes FD 8,+ -- - the parent opens FD 8 for some other purpose, e.g. for writing to a file,+ -- - the finalizer for the Handle wrapping FD 8 runs, closing FD 8, even though+ -- it is now in use for a completely different purpose.+ (ourFd, theirFd) <- swapIfTheyReadWeWrite <$> createPipeFd+ -- Don't allow the child process to inherit a parent file descriptor+ -- (such inheritance happens by default on Unix).+ setFdOption (Fd ourFd) CloseOnExec True+ -- NB: we will be closing this handle manually, so don't use 'handleFromFd'+ -- which attaches a finalizer that closes the FD. See the above comment+ -- about 'createPipeFd'.+ ourHandle <- getGhcHandle (Fd ourFd)+ return (ourHandle, CommunicationHandle $ Fd 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/Environment/OsString.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}++-- | Miscellaneous information about the system environment, for 'OsString'.+--+-- @since 1.6.26.0+module System.Process.Environment.OsString (+ getArgs,+ getEnv,+ getEnvironment,+ ) where++import Data.Coerce (coerce)+#if MIN_VERSION_filepath(1, 5, 0)+import "os-string" System.OsString.Internal.Types (OsString(OsString))+#else+import "filepath" System.OsString.Internal.Types (OsString(OsString))+#endif+#if defined(mingw32_HOST_OS)+import qualified System.Win32.WindowsString.Console as Platform+#else+import qualified System.Posix.Env.PosixString as Platform+#endif++-- | 'System.Environment.getArgs' for 'OsString'.+--+-- @since 1.6.26.0+getArgs :: IO [OsString]+getArgs = coerce Platform.getArgs++-- | 'System.Environment.getEnv' for 'OsString'.+--+-- @since 1.6.26.0+getEnv :: OsString -> IO (Maybe OsString)+getEnv = coerce Platform.getEnv++-- | 'System.Environment.getEnvironment' for 'OsString'.+--+-- @since 1.6.26.0+getEnvironment :: IO [(OsString, OsString)]+getEnvironment = coerce Platform.getEnvironment
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@@ -194,22 +200,22 @@ -- -- @ -- #if defined(__IO_MANAGER_WINIO__)--- import GHC.IO.SubSystem ((<!>))+-- import GHC.IO.SubSystem ((`<!>`)) -- import GHC.IO.Handle.Windows (handleToHANDLE) -- import GHC.Event.Windows (associateHandle') -- #endif -- -- ... ----- #if defined (__IO_MANAGER_WINIO__)--- return () <!> (do--- associateHandle' =<< handleToHANDLE <handle>)+-- #if defined(__IO_MANAGER_WINIO__)+-- return () \<!> do+-- associateHandle' =\<\< handleToHANDLE readEnd -- #endif -- @ -- -- Only associate handles that you are in charge of read/writing to. -- Do not associate handles passed to another process. It's the--- process's reponsibility to register the handle if it supports+-- process's responsibility to register the handle if it supports -- async access. -- -- @since 1.2.1.0@@ -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/Posix.hs view
@@ -136,7 +136,9 @@ maybeWith withFilePath mb_cwd $ \pWorkDir -> maybeWith with mb_child_group $ \pChildGroup -> maybeWith with mb_child_user $ \pChildUser ->- withMany withFilePath (cmd:args) $ \cstrs ->+ withFilePath cmd $ \cmdstr ->+ withMany withCString args $ \argstrs -> do+ let cstrs = cmdstr : argstrs withArray0 nullPtr cstrs $ \pargs -> do fdin <- mbFd fun fd_stdin mb_stdin
System/Process/Windows.hsc view
@@ -18,6 +18,8 @@ , terminateJobUnsafe , waitForJobCompletion , timeout_Infinite+ , HANDLE+ , mkNamedPipe ) where import System.Process.Common@@ -25,6 +27,8 @@ import Control.Exception import Control.Monad import Data.Bits+import Data.Char (toLower)+import Data.List (dropWhileEnd) import Foreign.C import Foreign.Marshal import Foreign.Ptr@@ -35,8 +39,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)@@ -56,7 +60,7 @@ ##if defined(i386_HOST_ARCH) ## define WINDOWS_CCONV stdcall-##elif defined(x86_64_HOST_ARCH)+##elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) ## define WINDOWS_CCONV ccall ##else ## error Unknown mingw32 arch@@ -425,9 +429,28 @@ -- which partly works. There seem to be some quoting issues, but -- I don't have the energy to find+fix them right now (ToDo). --SDM -- (later) Now I don't know what the above comment means. sigh.-commandToProcess (RawCommand cmd args) = do- return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args)+commandToProcess (RawCommand cmd args)+ | map toLower (takeWinExtension cmd) `elem` [".bat", ".cmd"]+ = return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateCmdExeArg) args)+ | otherwise+ = return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args) +-- TODO: filepath should also be updated with 'takeWinExtension'. Perhaps+-- some day we can remove this logic from `process` but there is no hurry.++-- | Get the extension of a Windows file, removing any trailing spaces or dots+-- since they are ignored.+--+-- See: <https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/file-folder-name-whitespace-characters>+--+-- >>> takeWinExtension "test.bat."+-- ".bat"+--+-- >>> takeWinExtension "test.bat ."+-- ".bat"+takeWinExtension :: FilePath -> String+takeWinExtension = takeExtension . dropWhileEnd (`elem` [' ', '.'])+ -- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as -- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation). findCommandInterpreter :: IO FilePath@@ -467,6 +490,31 @@ "findCommandInterpreter" Nothing Nothing) Just cmd -> return cmd +-- | Alternative regime used to escape arguments destined for scripts+-- interpreted by @cmd.exe@, (e.g. @.bat@ and @.cmd@ files).+--+-- This respects the Windows command interpreter's quoting rules:+--+-- * the entire argument should be surrounded in quotes+-- * the backslash symbol is used to escape quotes and backslashes+-- * the carat symbol is used to escape other special characters with+-- significance to the interpreter+--+-- It is particularly important that we perform this quoting as+-- unvalidated unquoted command-line arguments can be used to achieve+-- arbitrary user code execution in when passed to a vulnerable batch+-- script.+--+translateCmdExeArg :: String -> String+translateCmdExeArg xs = "^\"" ++ snd (foldr escape (True,"^\"") xs)+ where escape '"' (_, str) = (True, '\\' : '"' : str)+ escape '\\' (True, str) = (True, '\\' : '\\' : str)+ escape '\\' (False, str) = (False, '\\' : str)+ escape '%' (_, str) = (False, "%%cd:~,%" ++ str)+ escape c (_, str)+ | c `elem` "^<>|&()" = (False, '^' : c : str)+ | otherwise = (False, c : str)+ translateInternal :: String -> String translateInternal xs = '"' : snd (foldr escape (True,"\"") xs) where escape '"' (_, str) = (True, '\\' : '"' : str)@@ -514,16 +562,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/posix/common.h view
@@ -30,6 +30,7 @@ #endif // defined in fork_exec.c+#if defined(HAVE_FORK) ProcHandle do_spawn_fork (char *const args[], char *workingDirectory, char **environment,@@ -39,6 +40,7 @@ gid_t *childGroup, uid_t *childUser, int flags, char **failed_doing);+#endif // defined in posix_spawn.c ProcHandle
cbits/posix/fork_exec.c view
@@ -282,17 +282,18 @@ #if defined(HAVE_EXECVPE) // XXX Check result execvpe(args[0], args, environment);+ child_failed(forkCommunicationFds[1], "execvpe"); #else // XXX Check result execve(exec_path, args, environment);+ child_failed(forkCommunicationFds[1], "execve"); #endif } else { // XXX Check result execvp(args[0], args);+ child_failed(forkCommunicationFds[1], "execvp"); } - child_failed(forkCommunicationFds[1], "exec");- default: if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { setpgid(pid, pid);@@ -334,16 +335,8 @@ // our responsibility to reap here as nobody else can. waitpid(pid, NULL, 0); - // Already closed child ends above- if (stdInHdl->behavior == STD_HANDLE_USE_PIPE) {- close(stdInHdl->use_pipe.parent_end);- }- if (stdOutHdl->behavior == STD_HANDLE_USE_PIPE) {- close(stdOutHdl->use_pipe.parent_end);- }- if (stdErrHdl->behavior == STD_HANDLE_USE_PIPE) {- close(stdErrHdl->use_pipe.parent_end);- }+ // No need to close stdin, et al. here as runInteractiveProcess will+ // handle this. See #306. pid = -1; }
cbits/posix/posix_spawn.c view
@@ -1,3 +1,7 @@+// Necessary for POSIX_SPAWN_SETSID and posix_spawn_file_actions_addchdir_np under glibc.+// Moreover this needs to appear before any glibc headers.+#define _GNU_SOURCE+ #include "runProcess.h" #include "common.h" @@ -25,8 +29,6 @@ #else -// Necessary for POSIX_SPAWN_SETSID under glibc.-#define _GNU_SOURCE #include <spawn.h> extern char **environ;@@ -135,12 +137,33 @@ } if (workingDirectory) {-#if defined(HAVE_posix_spawn_file_actions_addchdir_np)- // N.B. this function is broken on macOS.- // See https://github.com/rust-lang/rust/pull/80537.+#if defined(HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR)+#if defined(HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP)+ // N.B. in certain toolchain versions, apple will act as if symbols exist+ // because the toolchain can be *used* for targets that have them.+ // At runtime, however, they will be NULL. So, if both symbols are+ // available, first check if the _np version *should* be available,+ // if it is, add a runtime check whether the non-_np version is NULL+ // and fallback to the _np version if it is+ // See also: https://github.com/haskell/process/issues/356+ if (posix_spawn_file_actions_addchdir == NULL) {+ r = posix_spawn_file_actions_addchdir_np(&fa, workingDirectory);+ } else {+ r = posix_spawn_file_actions_addchdir(&fa, workingDirectory);+ }+#else r = posix_spawn_file_actions_addchdir(&fa, workingDirectory);+#endif if (r != 0) { *failed_doing = "posix_spawn_file_actions_addchdir";+ goto fail;+ }+#elif defined(HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP)+ // N.B. this function is broken on macOS.+ // See https://github.com/rust-lang/rust/pull/80537.+ r = posix_spawn_file_actions_addchdir_np(&fa, workingDirectory);+ if (r != 0) {+ *failed_doing = "posix_spawn_file_actions_addchdir_np"; goto fail; } #else
cbits/posix/runProcess.c view
@@ -5,10 +5,13 @@ ------------------------------------------------------------------------- */ #include "runProcess.h"-#include "common.h" -#if defined(HAVE_FORK)+// Callers are stubbed out on wasm32: runInteractiveProcess (System/Process/Posix.hs),+// terminateProcess, getProcessExitCode, waitForProcess (System/Process.hs).+#if !defined(wasm32_HOST_ARCH) +#include "common.h"+ #include <unistd.h> #include <errno.h> #include <sys/wait.h>@@ -70,6 +73,7 @@ return r; } +#if defined(HAVE_FORK) r = do_spawn_fork(args, workingDirectory, environment, stdInHdl, stdOutHdl, stdErrHdl,@@ -77,6 +81,11 @@ flags, failed_doing); return r;+#else+ *failed_doing = "fork";+ return -1;+#endif+ } enum pipe_direction {@@ -268,4 +277,4 @@ return -1; } -#endif // HAVE_FORK+#endif // !wasm32_HOST_ARCH
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,86 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.30.0 *June 2026*++* darwin: Allow posix_spawn_file_actions_addchdir to be missing when+ linking against process ([#377](https://github.com/haskell/process/pull/377))++## 1.6.29.0 *May 2026*++* Stub out `runProcess.c` on wasm32 ([#366](https://github.com/haskell/process/pull/366))+* Fix segmentation faults on MacOS 15 caused by NULL symbols created by toolchains that can compile for MacOS 26 ([#363](https://github.com/haskell/process/pull/363))++## 1.6.28.0 *April 2026*++* Add `callCreateProcess`+* Improve Haddock++## 1.6.27.0 *March 2026*++* Support being configured without fork+* Fix `@since` annotations++## 1.6.26.1 *May 2025*++* Regenerate `configure` script (#343)++## 1.6.26.0 *April 2025*++* Add `System.Process.Environment.OsString`.+* Bumps `base >= 4.12.0.0` (GHC 8.6+), `filepath >= 1.4.100.0`,+ `unix >= 2.8.0.0`, and `Win32 >= 2.14.1.0`.+* Drops support for GHC < 8.6.++## 1.6.25.0 *September 2024*++* Fix build with Javascript backend ([#327](https://github.com/haskell/process/issues/327))++## 1.6.24.0 *September 2024*++* Fix detection of `posix_spawn_file_actions_addchdir[_np]` ([#303](https://github.com/haskell/process/issues/303))++## 1.6.23.0 *September 2024*++* Fix command-line escaping logic on Windows when the command file ends with+ a space or a dot. This is a follow-up for+ [HSEC-2024-0003](https://github.com/haskell/security-advisories/tree/main/advisories/hackage/process/HSEC-2024-0003.md).+* Migitate another manifestation of the BatBadBut vulnerability via+ unescaped `%` expansions. This is another follow-up for+ [HSEC-2024-0003](https://github.com/haskell/security-advisories/tree/main/advisories/hackage/process/HSEC-2024-0003.md).+ ([#313](https://github.com/haskell/process/issues/313))++## 1.6.22.0 *August 2024*++* Allow NUL to appear in arguments under POSIX. See+ https://github.com/haskell/process/pull/320. Thanks to @mmhat.++## 1.6.21.0 *July 2024*++* No longer attach finalizers to `Handle`s created by the+ `System.Process.CommunicationHandle` API. Instead, all file descriptors are+ manually closed by the API.++ This fixes a bug in which a file descriptor could be closed multiple times.++## 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+ characters with special significance to the Windows batch interpreter are+ 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* * Fix deadlock when waiting for process completion and process jobs [#273](https://github.com/haskell/process/issues/273)
configure view
@@ -3981,6 +3981,12 @@ printf "%s\n" "#define HAVE_POSIX_SPAWNP 1" >>confdefs.h fi+ac_fn_c_check_func "$LINENO" "posix_spawn_file_actions_addchdir_np" "ac_cv_func_posix_spawn_file_actions_addchdir_np"+if test "x$ac_cv_func_posix_spawn_file_actions_addchdir_np" = xyes+then :+ printf "%s\n" "#define HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP 1" >>confdefs.h++fi ac_fn_c_check_func "$LINENO" "posix_spawn_file_actions_addchdir" "ac_cv_func_posix_spawn_file_actions_addchdir" if test "x$ac_cv_func_posix_spawn_file_actions_addchdir" = xyes then :
configure.ac view
@@ -23,7 +23,7 @@ # posix_spawn checks AC_CHECK_HEADERS([spawn.h])-AC_CHECK_FUNCS([posix_spawnp posix_spawn_file_actions_addchdir],[],[],[+AC_CHECK_FUNCS([posix_spawnp posix_spawn_file_actions_addchdir_np posix_spawn_file_actions_addchdir],[],[],[ #define _GNU_SOURCE #include <spawn.h> ])
include/HsProcessConfig.h.in view
@@ -40,6 +40,10 @@ */ #undef HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR +/* Define to 1 if you have the `posix_spawn_file_actions_addchdir_np'+ function. */+#undef HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP+ /* Define to 1 if you have the `setitimer' function. */ #undef HAVE_SETITIMER
process.cabal view
@@ -1,14 +1,14 @@+cabal-version: 2.4 name: process-version: 1.6.18.0+version: 1.6.30.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@@ -39,6 +41,11 @@ type: git location: https://github.com/haskell/process.git +flag os-string+ description: Use the new os-string package+ default: False+ manual: False+ library default-language: Haskell2010 other-extensions:@@ -52,18 +59,22 @@ exposed-modules: System.Cmd System.Process+ System.Process.CommunicationHandle+ System.Process.CommunicationHandle.Internal+ System.Process.Environment.OsString System.Process.Internals other-modules: System.Process.Common if os(windows) c-sources: cbits/win32/runProcess.c other-modules: System.Process.Windows- build-depends: Win32 >=2.4 && < 2.14+ build-depends: Win32 >= 2.14.1.0 && < 2.15 -- ole32 and rpcrt4 are needed to create GUIDs for unique named pipes -- for process. extra-libraries: kernel32, ole32, rpcrt4 cpp-options: -DWINDOWS else+ build-depends: unix >= 2.8.0.0 && < 2.9 if arch(javascript) js-sources: jsbits/process.js@@ -75,34 +86,33 @@ cbits/posix/posix_spawn.c cbits/posix/find_executable.c other-modules: System.Process.Posix- build-depends: unix >= 2.5 && < 2.9 + -- On macOS, posix_spawn_file_actions_addchdir is available from macOS >= 26.+ -- We weakly reference this symbol when we are build on such a platform.+ -- However, weak references on MachO are hints to the dynamic loader, not the+ -- static linker, which will still expect the symbol to be defined somewhere.+ -- This means linking fails when we try to link an executable depending on+ -- process on a toolchain which doesn't have this symbol against a process+ -- library build on a toolchain with the symbol.+ -- See https://github.com/haskell/process/issues/376+ -- Hence: instruct the linker to explicilty allow undefined references to+ -- the symbol when linking against process on darwin+ if os(darwin)+ ld-options: -Wl,-U,_posix_spawn_file_actions_addchdir+ include-dirs: include- includes:- runProcess.h install-includes: runProcess.h processFlags.h ghc-options: -Wall - build-depends: base >= 4.10 && < 4.20,+ build-depends: base >= 4.12.0.0 && < 4.24, directory >= 1.1 && < 1.4,- filepath >= 1.2 && < 1.5, 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+ if flag(os-string)+ build-depends: filepath >= 1.5.0.0 && < 1.6,+ os-string >= 2.0.0 && < 2.1+ else+ build-depends: filepath >= 1.4.100.0 && < 1.5.0.0
− 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)