process 1.4.0.0 → 1.4.1.0
raw patch · 7 files changed
+851/−759 lines, 7 files
Files
- System/Process.hsc +3/−97
- System/Process/Common.hs +215/−0
- System/Process/Internals.hs +42/−653
- System/Process/Posix.hs +291/−0
- System/Process/Windows.hsc +283/−0
- changelog.md +6/−0
- process.cabal +11/−9
System/Process.hsc view
@@ -1,12 +1,10 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-#ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE InterruptibleFFI #-}-#endif ----------------------------------------------------------------------------- -- |@@ -87,25 +85,12 @@ import System.IO import System.IO.Error (mkIOError, ioeSetErrorString) -#if defined(mingw32_HOST_OS)-# include <io.h> /* for _close and _pipe */-# include <fcntl.h> /* for _O_BINARY */-import Control.Exception (onException)-#else-import System.Posix.Process (getProcessGroupIDOf)-import qualified System.Posix.IO as Posix-import System.Posix.Types+-- Provide the data constructors for CPid on GHC 7.4 and later+#if !defined(WINDOWS) && MIN_VERSION_base(4,5,0)+import System.Posix.Types (CPid (..)) #endif -#ifdef __GLASGOW_HASKELL__ import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )-# if defined(mingw32_HOST_OS)-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT)-import System.Win32.Process (getProcessId)-# else-import System.Posix.Signals-# endif-#endif -- ---------------------------------------------------------------------------- -- createProcess@@ -559,15 +544,11 @@ restore (body wait) `C.onException` killThread tid ignoreSigPipe :: IO () -> IO ()-#if defined(__GLASGOW_HASKELL__) ignoreSigPipe = C.handle $ \e -> case e of IOError { ioe_type = ResourceVanished , ioe_errno = Just ioe } | Errno ioe == ePIPE -> return () _ -> throwIO e-#else-ignoreSigPipe = id-#endif -- ---------------------------------------------------------------------------- -- showCommandForUser@@ -690,37 +671,6 @@ -- ------------------------------------------------------------------------------- interruptProcessGroupOf---- | Sends an interrupt signal to the process group of the given process.------ On Unix systems, it sends the group the SIGINT signal.------ On Windows systems, it generates a CTRL_BREAK_EVENT and will only work for--- processes created using 'createProcess' and setting the 'create_group' flag--interruptProcessGroupOf- :: ProcessHandle -- ^ A process in the process group- -> IO ()-interruptProcessGroupOf ph = do- withProcessHandle ph $ \p_ -> do- case p_ of- ClosedHandle _ -> return ()- OpenHandle h -> do-#if mingw32_HOST_OS- pid <- getProcessId h- generateConsoleCtrlEvent cTRL_BREAK_EVENT pid--- We can't use an #elif here, because MIN_VERSION_unix isn't defined--- on Windows, so on Windows cpp fails:--- error: missing binary operator before token "("-#else- pgid <- getProcessGroupIDOf h- signalProcessGroup sigINT pgid-#endif- return ()----- ---------------------------------------------------------------------------- -- Interface to C bits foreign import ccall unsafe "terminateProcess"@@ -902,13 +852,11 @@ On Unix systems, see 'waitForProcess' for the meaning of exit codes when the process died as the result of a signal. -}-#ifdef __GLASGOW_HASKELL__ system :: String -> IO ExitCode system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") system str = do (_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True } waitForProcess p-#endif /* __GLASGOW_HASKELL__ */ --TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-}@@ -922,48 +870,6 @@ The return codes and possible failures are the same as for 'system'. -} rawSystem :: String -> [String] -> IO ExitCode-#ifdef __GLASGOW_HASKELL__ rawSystem cmd args = do (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } waitForProcess p-#elif !mingw32_HOST_OS--- crude fallback implementation: could do much better than this under Unix-rawSystem cmd args = system (showCommandForUser cmd args)-#else-rawSystem cmd args = system (showCommandForUser cmd args)-#endif---- ------------------------------------------------------------------------------ createPipe---- | Create a pipe for interprocess communication and return a--- @(readEnd, writeEnd)@ `Handle` pair.------ @since 1.2.1.0-createPipe :: IO (Handle, Handle)-#if !mingw32_HOST_OS-createPipe = do- (readfd, writefd) <- Posix.createPipe- readh <- Posix.fdToHandle readfd- writeh <- Posix.fdToHandle writefd- return (readh, writeh)-#else-createPipe = do- (readfd, writefd) <- allocaArray 2 $ \ pfds -> do- throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)- readfd <- peek pfds- writefd <- peekElemOff pfds 1- return (readfd, writefd)- (do readh <- fdToHandle readfd- writeh <- fdToHandle writefd- return (readh, writeh)) `onException` (close readfd >> close writefd)--close :: CInt -> IO ()-close = throwErrnoIfMinus1_ "_close" . c__close--foreign import ccall "io.h _pipe" c__pipe ::- Ptr CInt -> CUInt -> CInt -> IO CInt--foreign import ccall "io.h _close" c__close ::- CInt -> IO CInt-#endif
+ System/Process/Common.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+module System.Process.Common+ ( CreateProcess (..)+ , CmdSpec (..)+ , StdStream (..)+ , ProcessHandle(..)+ , ProcessHandle__(..)+ , withFilePathException+ , PHANDLE+ , modifyProcessHandle+ , withProcessHandle+ , fd_stdin+ , fd_stdout+ , fd_stderr+ , mbFd+ , mbPipe+ , pfdToHandle++-- Avoid a warning on Windows+#ifdef WINDOWS+ , CGid (..)+#else+ , CGid+#endif+ ) where++import Control.Concurrent+import Control.Exception+import Data.String+import Foreign.Ptr+import Foreign.Storable++import System.Posix.Internals+import GHC.IO.Exception+import GHC.IO.Encoding+import qualified GHC.IO.FD as FD+import GHC.IO.Device+import GHC.IO.Handle.FD+import GHC.IO.Handle.Internals+import GHC.IO.Handle.Types hiding (ClosedHandle)+import System.IO.Error+import Data.Typeable+import GHC.IO.IOMode++-- We do a minimal amount of CPP here to provide uniform data types across+-- Windows and POSIX.+#ifdef WINDOWS+import Data.Word (Word32)+import System.Win32.DebugApi (PHANDLE)+#else+import System.Posix.Types+#endif++#ifdef WINDOWS+-- 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.+newtype CGid = CGid Word32+type GroupID = CGid+type UserID = CGid+#else+type PHANDLE = CPid+#endif++data CreateProcess = CreateProcess{+ cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command+ cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process+ env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)+ 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)+ create_group :: Bool, -- ^ Create a new process group+ delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).+ --+ -- On Windows this has no effect.+ --+ -- @since 1.2.0.0+ detach_console :: Bool, -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms.+ --+ -- @since 1.3.0.0+ create_new_console :: Bool, -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; does nothing on other platforms.+ --+ -- Default: @False@+ --+ -- @since 1.3.0.0+ new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms.+ --+ -- @since 1.3.0.0+ child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; does nothing on other platforms.+ --+ -- Default: @Nothing@+ --+ -- @since 1.4.0.0+ child_user :: Maybe UserID -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.+ --+ -- Default: @Nothing@+ --+ -- @since 1.4.0.0+ }++data CmdSpec+ = ShellCommand String+ -- ^ A command line to execute using the shell+ | RawCommand FilePath [String]+ -- ^ The name of an executable with a list of arguments+ --+ -- The 'FilePath' argument names the executable, and is interpreted+ -- according to the platform's standard policy for searching for+ -- executables. Specifically:+ --+ -- * on Unix systems the+ -- <http://pubs.opengroup.org/onlinepubs/9699919799/functions/execvp.html execvp(3)>+ -- semantics is used, where if the executable filename does not+ -- contain a slash (@/@) then the @PATH@ environment variable is+ -- searched for the executable.+ --+ -- * on Windows systems the Win32 @CreateProcess@ semantics is used.+ -- Briefly: if the filename does not contain a path, then the+ -- directory containing the parent executable is searched, followed+ -- by the current directory, then some standard locations, and+ -- finally the current @PATH@. An @.exe@ extension is added if the+ -- filename does not already have an extension. For full details+ -- see the+ -- <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365527%28v=vs.85%29.aspx documentation>+ -- for the Windows @SearchPath@ API.+++-- | construct a `ShellCommand` from a string literal+--+-- @since 1.2.1.0+instance IsString CmdSpec where+ fromString = ShellCommand++data StdStream+ = Inherit -- ^ Inherit Handle from parent+ | UseHandle Handle -- ^ Use the supplied Handle+ | CreatePipe -- ^ Create a new pipe. The returned+ -- @Handle@ will use the default encoding+ -- and newline translation mode (just+ -- like @Handle@s created by @openFile@).+ | NoStream -- ^ No stream handle will be passed++-- ----------------------------------------------------------------------------+-- ProcessHandle type++{- | A handle to a process, which can be used to wait for termination+ of the process using 'System.Process.waitForProcess'.++ None of the process-creation functions in this library wait for+ termination: they all return a 'ProcessHandle' which may be used+ to wait for the process later.+-}+data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode+data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool++withFilePathException :: FilePath -> IO a -> IO a+withFilePathException fpath act = handle mapEx act+ where+ mapEx ex = ioError (ioeSetFileName ex fpath)++modifyProcessHandle+ :: ProcessHandle+ -> (ProcessHandle__ -> IO (ProcessHandle__, a))+ -> IO a+modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io++withProcessHandle+ :: ProcessHandle+ -> (ProcessHandle__ -> IO a)+ -> IO a+withProcessHandle (ProcessHandle m _) io = withMVar m io++fd_stdin, fd_stdout, fd_stderr :: FD+fd_stdin = 0+fd_stdout = 1+fd_stderr = 2++mbFd :: String -> FD -> StdStream -> IO FD+mbFd _ _std CreatePipe = return (-1)+mbFd _fun std Inherit = return std+mbFd _fn _std NoStream = return (-2)+mbFd fun _std (UseHandle hdl) =+ withHandle fun hdl $ \Handle__{haDevice=dev,..} ->+ case cast dev of+ Just fd -> do+ -- clear the O_NONBLOCK flag on this FD, if it is set, since+ -- we're exposing it externally (see #3316)+ fd' <- FD.setNonBlockingMode fd False+ return (Handle__{haDevice=fd',..}, FD.fdFD fd')+ Nothing ->+ ioError (mkIOError illegalOperationErrorType+ "createProcess" (Just hdl) Nothing+ `ioeSetErrorString` "handle is not a file descriptor")++mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)+mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)+mbPipe _std _pfd _mode = return Nothing++pfdToHandle :: Ptr FD -> IOMode -> IO Handle+pfdToHandle pfd mode = do+ fd <- peek pfd+ let filepath = "fd:" ++ show fd+ (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode+ (Just (Stream,0,0)) -- avoid calling fstat()+ False {-is_socket-}+ False {-non-blocking-}+ fD' <- FD.setNonBlockingMode fD True -- see #3316+#if __GLASGOW_HASKELL__ >= 704+ enc <- getLocaleEncoding+#else+ let enc = localeEncoding+#endif+ mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)
System/Process/Internals.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE CPP, RecordWildCards, BangPatterns #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE InterruptibleFFI #-}-#endif ----------------------------------------------------------------------------- -- |@@ -25,237 +23,39 @@ ProcessHandle(..), ProcessHandle__(..), PHANDLE, closePHANDLE, mkProcessHandle, modifyProcessHandle, withProcessHandle,-#ifdef __GLASGOW_HASKELL__ CreateProcess(..), CmdSpec(..), StdStream(..), createProcess_, runGenProcess_, --deprecated-#endif+ fdToHandle, startDelegateControlC, endDelegateControlC, stopDelegateControlC,-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+#ifndef WINDOWS pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, #endif withFilePathException, withCEnvironment, translate,- fdToHandle,+ createPipe,+ interruptProcessGroupOf, ) where -import Control.Concurrent-import Control.Exception-import Data.Bits-import Data.String import Foreign.C-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import System.IO.Unsafe--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-import Control.Monad-import Data.Char import System.IO-import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )-import System.Posix.Types-#else-import Data.Word (Word32)-#endif -#ifdef __GLASGOW_HASKELL__-import System.Posix.Internals-import GHC.IO.Exception-import GHC.IO.Encoding-import qualified GHC.IO.FD as FD-import GHC.IO.Device-import GHC.IO.Handle.FD-import GHC.IO.Handle.Internals-import GHC.IO.Handle.Types hiding (ClosedHandle)-import System.IO.Error-import Data.Typeable-# if defined(mingw32_HOST_OS)-import GHC.IO.IOMode-import System.Win32.DebugApi (PHANDLE)-# else-import System.Posix.Signals as Sig-# endif-#endif--#if defined(mingw32_HOST_OS)-import System.Directory ( doesFileExist )-import System.Environment ( getEnv )-import System.FilePath-#endif--#include "HsProcessConfig.h"-#include "processFlags.h"--#ifdef mingw32_HOST_OS-# if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall-# else-# error Unknown mingw32 arch-# endif-#endif--#if defined(mingw32_HOST_OS) || defined(__MINGW32__)--- Define some missing types for Windows compatibility-newtype CGid = CGid Word32-type GroupID = CGid-type UserID = CGid-#endif---- ------------------------------------------------------------------------------- ProcessHandle type--{- | A handle to a process, which can be used to wait for termination- of the process using 'System.Process.waitForProcess'.-- None of the process-creation functions in this library wait for- termination: they all return a 'ProcessHandle' which may be used- to wait for the process later.--}-data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode-data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool--modifyProcessHandle- :: ProcessHandle- -> (ProcessHandle__ -> IO (ProcessHandle__, a))- -> IO a-modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io--withProcessHandle- :: ProcessHandle- -> (ProcessHandle__ -> IO a)- -> IO a-withProcessHandle (ProcessHandle m _) io = withMVar m io--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)--type PHANDLE = CPid--mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle-mkProcessHandle p mb_delegate_ctlc = do- m <- newMVar (OpenHandle p)- return (ProcessHandle m mb_delegate_ctlc)+import GHC.IO.Handle.FD (fdToHandle) -closePHANDLE :: PHANDLE -> IO ()-closePHANDLE _ = return ()+import System.Process.Common +#if WINDOWS+import System.Process.Windows #else--throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE-throwErrnoIfBadPHandle = throwErrnoIfNull---- On Windows, we have to close this HANDLE when it is no longer required,--- hence we add a finalizer to it-mkProcessHandle :: PHANDLE -> IO ProcessHandle-mkProcessHandle h = do- m <- newMVar (OpenHandle h)- _ <- mkWeakMVar m (processHandleFinaliser m)- return (ProcessHandle m False)--processHandleFinaliser :: MVar ProcessHandle__ -> IO ()-processHandleFinaliser m =- modifyMVar_ m $ \p_ -> do- case p_ of- OpenHandle ph -> closePHANDLE ph- _ -> return ()- return (error "closed process handle")--closePHANDLE :: PHANDLE -> IO ()-closePHANDLE ph = c_CloseHandle ph--foreign import WINDOWS_CCONV unsafe "CloseHandle"- c_CloseHandle- :: PHANDLE- -> IO ()+import System.Process.Posix #endif -- ---------------------------------------------------------------------------- -data CreateProcess = CreateProcess{- cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command- cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process- env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)- 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)- create_group :: Bool, -- ^ Create a new process group- delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).- --- -- On Windows this has no effect.- --- -- @since 1.2.0.0- detach_console :: Bool, -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms.- --- -- @since 1.3.0.0- create_new_console :: Bool, -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; does nothing on other platforms.- --- -- Default: @False@- --- -- @since 1.3.0.0- new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms.- --- -- @since 1.3.0.0- child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; does nothing on other platforms.- --- -- Default: @Nothing@- --- -- @since 1.4.0.0- child_user :: Maybe UserID -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.- --- -- Default: @Nothing@- --- -- @since 1.4.0.0- }--data CmdSpec- = ShellCommand String- -- ^ A command line to execute using the shell- | RawCommand FilePath [String]- -- ^ The name of an executable with a list of arguments- --- -- The 'FilePath' argument names the executable, and is interpreted- -- according to the platform's standard policy for searching for- -- executables. Specifically:- --- -- * on Unix systems the- -- <http://pubs.opengroup.org/onlinepubs/9699919799/functions/execvp.html execvp(3)>- -- semantics is used, where if the executable filename does not- -- contain a slash (@/@) then the @PATH@ environment variable is- -- searched for the executable.- --- -- * on Windows systems the Win32 @CreateProcess@ semantics is used.- -- Briefly: if the filename does not contain a path, then the- -- directory containing the parent executable is searched, followed- -- by the current directory, then some standard locations, and- -- finally the current @PATH@. An @.exe@ extension is added if the- -- filename does not already have an extension. For full details- -- see the- -- <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365527%28v=vs.85%29.aspx documentation>- -- for the Windows @SearchPath@ API.----- | construct a `ShellCommand` from a string literal------ @since 1.2.1.0-instance IsString CmdSpec where- fromString = ShellCommand--data StdStream- = Inherit -- ^ Inherit Handle from parent- | UseHandle Handle -- ^ Use the supplied Handle- | CreatePipe -- ^ Create a new pipe. The returned- -- @Handle@ will use the default encoding- -- and newline translation mode (just- -- like @Handle@s created by @openFile@).- | NoStream -- ^ No stream handle will be passed- -- | This function is almost identical to -- 'System.Process.createProcess'. The only differences are: --@@ -273,399 +73,8 @@ :: String -- ^ function name (for error messages) -> CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)--#ifdef __GLASGOW_HASKELL__---- -------------------------------------------------------------------------------- POSIX runProcess with signal handling in the child--createProcess_ fun CreateProcess{ cmdspec = cmdsp,- cwd = mb_cwd,- env = mb_env,- std_in = mb_stdin,- std_out = mb_stdout,- std_err = mb_stderr,- close_fds = mb_close_fds,- create_group = mb_create_group,- delegate_ctlc = mb_delegate_ctlc,- detach_console = mb_detach_console,- create_new_console = mb_create_new_console,- new_session = mb_new_session,- child_group = mb_child_group,- child_user = mb_child_user }- = do- let (cmd,args) = commandToProcess cmdsp- withFilePathException cmd $- alloca $ \ pfdStdInput ->- alloca $ \ pfdStdOutput ->- alloca $ \ pfdStdError ->- alloca $ \ pFailedDoing ->- maybeWith withCEnvironment mb_env $ \pEnv ->- maybeWith withFilePath mb_cwd $ \pWorkDir ->- maybeWith with mb_child_group $ \pChildGroup ->- maybeWith with mb_child_user $ \pChildUser ->- withMany withFilePath (cmd:args) $ \cstrs ->- withArray0 nullPtr cstrs $ \pargs -> do-- fdin <- mbFd fun fd_stdin mb_stdin- fdout <- mbFd fun fd_stdout mb_stdout- fderr <- mbFd fun fd_stderr mb_stderr-- when mb_delegate_ctlc- startDelegateControlC-- -- runInteractiveProcess() blocks signals around the fork().- -- Since blocking/unblocking of signals is a global state- -- operation, we better ensure mutual exclusion of calls to- -- runInteractiveProcess().- proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->- c_runInteractiveProcess pargs pWorkDir pEnv- fdin fdout fderr- pfdStdInput pfdStdOutput pfdStdError- pChildGroup pChildUser- (if mb_delegate_ctlc then 1 else 0)- ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)- .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)- .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)- .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)- .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))- pFailedDoing-- when (proc_handle == -1) $ do- cFailedDoing <- peek pFailedDoing- failedDoing <- peekCString cFailedDoing- when mb_delegate_ctlc- stopDelegateControlC- throwErrno (fun ++ ": " ++ failedDoing)-- hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode- hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode- hndStdError <- mbPipe mb_stderr pfdStdError ReadMode-- ph <- mkProcessHandle proc_handle mb_delegate_ctlc- return (hndStdInput, hndStdOutput, hndStdError, ph)--{-# NOINLINE runInteractiveProcess_lock #-}-runInteractiveProcess_lock :: MVar ()-runInteractiveProcess_lock = unsafePerformIO $ newMVar ()---- ------------------------------------------------------------------------------- Delegated control-C handling on Unix---- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301--- and http://www.cons.org/cracauer/sigint.html------ While running an interactive console process like ghci or a shell, we want--- to let that process handle Ctl-C keyboard interrupts how it sees fit.--- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're--- running such programs. And then if/when they do terminate, we need to check--- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we--- got the Ctl-C then, by throwing the UserInterrupt exception.------ If we run multiple programs like this concurrently then we have to be--- careful to avoid messing up the signal handlers. We keep a count and only--- restore when the last one has finished.--{-# NOINLINE runInteractiveProcess_delegate_ctlc #-}-runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))-runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing--startDelegateControlC :: IO ()-startDelegateControlC =- modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do- case delegating of- Nothing -> do- -- We're going to ignore ^C in the parent while there are any- -- processes using ^C delegation.- --- -- If another thread runs another process without using- -- delegation while we're doing this then it will inherit the- -- ignore ^C status.- old_int <- installHandler sigINT Ignore Nothing- old_quit <- installHandler sigQUIT Ignore Nothing- return (Just (1, old_int, old_quit))-- Just (count, old_int, old_quit) -> do- -- If we're already doing it, just increment the count- let !count' = count + 1- return (Just (count', old_int, old_quit))--stopDelegateControlC :: IO ()-stopDelegateControlC =- modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do- case delegating of- Just (1, old_int, old_quit) -> do- -- Last process, so restore the old signal handlers- _ <- installHandler sigINT old_int Nothing- _ <- installHandler sigQUIT old_quit Nothing- return Nothing-- Just (count, old_int, old_quit) -> do- -- Not the last, just decrement the count- let !count' = count - 1- return (Just (count', old_int, old_quit))-- Nothing -> return Nothing -- should be impossible--endDelegateControlC :: ExitCode -> IO ()-endDelegateControlC exitCode = do- stopDelegateControlC-- -- And if the process did die due to SIGINT or SIGQUIT then- -- we throw our equivalent exception here (synchronously).- --- -- An alternative design would be to throw to the main thread, as the- -- normal signal handler does. But since we can be sync here, we do so.- -- It allows the code locally to catch it and do something.- case exitCode of- ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt- _ -> return ()- where- isSigIntQuit n = sig == sigINT || sig == sigQUIT- where- sig = fromIntegral (-n)--foreign import ccall unsafe "runInteractiveProcess"- c_runInteractiveProcess- :: Ptr CString- -> CString- -> Ptr CString- -> FD- -> FD- -> FD- -> Ptr FD- -> Ptr FD- -> Ptr FD- -> Ptr CGid- -> Ptr CUid- -> CInt -- reset child's SIGINT & SIGQUIT handlers- -> CInt -- flags- -> Ptr CString- -> IO PHANDLE--#endif /* __GLASGOW_HASKELL__ */--ignoreSignal, defaultSignal :: CLong-ignoreSignal = CONST_SIG_IGN-defaultSignal = CONST_SIG_DFL--#else--#ifdef __GLASGOW_HASKELL__--createProcess_ fun CreateProcess{ cmdspec = cmdsp,- cwd = mb_cwd,- env = mb_env,- std_in = mb_stdin,- std_out = mb_stdout,- std_err = mb_stderr,- close_fds = mb_close_fds,- create_group = mb_create_group,- delegate_ctlc = _ignored,- detach_console = mb_detach_console,- create_new_console = mb_create_new_console,- new_session = mb_new_session }- = do- (cmd, cmdline) <- commandToProcess cmdsp- withFilePathException cmd $- alloca $ \ pfdStdInput ->- alloca $ \ pfdStdOutput ->- alloca $ \ pfdStdError ->- maybeWith withCEnvironment mb_env $ \pEnv ->- maybeWith withCWString mb_cwd $ \pWorkDir -> do- withCWString cmdline $ \pcmdline -> do-- fdin <- mbFd fun fd_stdin mb_stdin- fdout <- mbFd fun fd_stdout mb_stdout- fderr <- mbFd fun fd_stderr mb_stderr-- -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,- -- because otherwise there is a race condition whereby one thread- -- has created some pipes, and another thread spawns a process which- -- accidentally inherits some of the pipe handles that the first- -- thread has created.- --- -- An MVar in Haskell is the best way to do this, because there- -- is no way to do one-time thread-safe initialisation of a mutex- -- the C code. Also the MVar will be cheaper when not running- -- the threaded RTS.- proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->- throwErrnoIfBadPHandle fun $- c_runInteractiveProcess pcmdline pWorkDir pEnv- fdin fdout fderr- pfdStdInput pfdStdOutput pfdStdError- ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)- .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)- .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)- .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)- .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))-- hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode- hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode- hndStdError <- mbPipe mb_stderr pfdStdError ReadMode-- ph <- mkProcessHandle proc_handle- return (hndStdInput, hndStdOutput, hndStdError, ph)--{-# NOINLINE runInteractiveProcess_lock #-}-runInteractiveProcess_lock :: MVar ()-runInteractiveProcess_lock = unsafePerformIO $ newMVar ()---- The following functions are always present in the export list. For--- compatibility with the non-Windows code, we provide the same functions with--- matching type signatures, but implemented as no-ops. For details, see:--- <https://github.com/haskell/process/pull/21>-startDelegateControlC :: IO ()-startDelegateControlC = return ()--endDelegateControlC :: ExitCode -> IO ()-endDelegateControlC _ = return ()--stopDelegateControlC :: IO ()-stopDelegateControlC = return ()---- End no-op functions--foreign import ccall unsafe "runInteractiveProcess"- c_runInteractiveProcess- :: CWString- -> CWString- -> Ptr CWString- -> FD- -> FD- -> FD- -> Ptr FD- -> Ptr FD- -> Ptr FD- -> CInt -- flags- -> IO PHANDLE-#endif--#endif /* __GLASGOW_HASKELL__ */--fd_stdin, fd_stdout, fd_stderr :: FD-fd_stdin = 0-fd_stdout = 1-fd_stderr = 2--mbFd :: String -> FD -> StdStream -> IO FD-mbFd _ _std CreatePipe = return (-1)-mbFd _fun std Inherit = return std-mbFd _fn _std NoStream = return (-2)-mbFd fun _std (UseHandle hdl) =- withHandle fun hdl $ \Handle__{haDevice=dev,..} ->- case cast dev of- Just fd -> do- -- clear the O_NONBLOCK flag on this FD, if it is set, since- -- we're exposing it externally (see #3316)- fd' <- FD.setNonBlockingMode fd False- return (Handle__{haDevice=fd',..}, FD.fdFD fd')- Nothing ->- ioError (mkIOError illegalOperationErrorType- "createProcess" (Just hdl) Nothing- `ioeSetErrorString` "handle is not a file descriptor")--mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)-mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)-mbPipe _std _pfd _mode = return Nothing--pfdToHandle :: Ptr FD -> IOMode -> IO Handle-pfdToHandle pfd mode = do- fd <- peek pfd- let filepath = "fd:" ++ show fd- (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode- (Just (Stream,0,0)) -- avoid calling fstat()- False {-is_socket-}- False {-non-blocking-}- fD' <- FD.setNonBlockingMode fD True -- see #3316-#if __GLASGOW_HASKELL__ >= 704- enc <- getLocaleEncoding-#else- let enc = localeEncoding-#endif- mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)---- ------------------------------------------------------------------------------- commandToProcess--{- | Turns a shell command into a raw command. Usually this involves- wrapping it in an invocation of the shell.-- There's a difference in the signature of commandToProcess between- the Windows and Unix versions. On Unix, exec takes a list of strings,- and we want to pass our command to /bin/sh as a single argument.-- On Windows, CreateProcess takes a single string for the command,- which is later decomposed by cmd.exe. In this case, we just want- to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line. The- command-line translation that we normally do for arguments on- Windows isn't required (or desirable) here.--}--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)--commandToProcess :: CmdSpec -> (FilePath, [String])-commandToProcess (ShellCommand string) = ("/bin/sh", ["-c", string])-commandToProcess (RawCommand cmd args) = (cmd, args)--#else--commandToProcess- :: CmdSpec- -> IO (FilePath, String)-commandToProcess (ShellCommand string) = do- cmd <- findCommandInterpreter- return (cmd, translate cmd ++ " /c " ++ string)- -- We don't want to put the cmd into a single- -- argument, because cmd.exe will not try to split it up. Instead,- -- we just tack the command on the end of the cmd.exe command line,- -- 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, translate cmd ++ concatMap ((' ':) . translate) args)---- 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-findCommandInterpreter = do- -- try COMSPEC first- catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)- (getEnv "COMSPEC") $ \_ -> do-- -- try to find CMD.EXE or COMMAND.COM- {-- XXX We used to look at _osver (using cbits) and pick which shell to- use with- let filename | osver .&. 0x8000 /= 0 = "command.com"- | otherwise = "cmd.exe"- We ought to use GetVersionEx instead, but for now we just look for- either filename- -}- path <- getEnv "PATH"- let- -- use our own version of System.Directory.findExecutable, because- -- that assumes the .exe suffix.- search :: [FilePath] -> IO (Maybe FilePath)- search [] = return Nothing- search (d:ds) = do- let path1 = d </> "cmd.exe"- path2 = d </> "command.com"- b1 <- doesFileExist path1- b2 <- doesFileExist path2- if b1 then return (Just path1)- else if b2 then return (Just path2)- else search ds- --- mb_path <- search (splitSearchPath path)-- case mb_path of- Nothing -> ioError (mkIOError doesNotExistErrorType- "findCommandInterpreter" Nothing Nothing)- Just cmd -> return cmd-#endif+createProcess_ = createProcess_Internal+{-# INLINE createProcess_ #-} -- ------------------------------------------------------------------------ -- Escaping commands for shells@@ -723,55 +132,13 @@ -} translate :: String -> String-#if mingw32_HOST_OS-translate xs = '"' : snd (foldr escape (True,"\"") xs)- where escape '"' (_, str) = (True, '\\' : '"' : str)- escape '\\' (True, str) = (True, '\\' : '\\' : str)- escape '\\' (False, str) = (False, '\\' : str)- escape c (_, str) = (False, c : str)- -- See long comment above for what this function is trying to do.- --- -- The Bool passed back along the string is True iff the- -- rest of the string is a sequence of backslashes followed by- -- a double quote.-#else-translate "" = "''"-translate str- -- goodChar is a pessimistic predicate, such that if an argument is- -- non-empty and only contains goodChars, then there is no need to- -- do any quoting or escaping- | all goodChar str = str- | otherwise = '\'' : foldr escape "'" str- where escape '\'' = showString "'\\''"- escape c = showChar c- goodChar c = isAlphaNum c || c `elem` "-_.,/"-#endif---- ------------------------------------------------------------------------------- Utils--withFilePathException :: FilePath -> IO a -> IO a-withFilePathException fpath act = handle mapEx act- where- mapEx ex = ioError (ioeSetFileName ex fpath)--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a-withCEnvironment envir act =- let env' = map (\(name, val) -> name ++ ('=':val)) envir- in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)-#else-withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a-withCEnvironment envir act =- let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" envir- in withCWString env' (act . castPtr)-#endif+translate = translateInternal+{-# INLINE translate #-} -- ---------------------------------------------------------------------------- -- Deprecated / compat -#ifdef __GLASGOW_HASKELL__ {-# DEPRECATED runGenProcess_ "Please do not use this anymore, use the ordinary 'System.Process.createProcess'. If you need the SIGINT handling, use delegate_ctlc = True (runGenProcess_ is now just an imperfectly emulated stub that probably duplicates or overrides your own signal handling)." #-} runGenProcess_@@ -780,12 +147,34 @@ -> Maybe CLong -- ^ handler for SIGINT -> Maybe CLong -- ^ handler for SIGQUIT -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-runGenProcess_ fun c (Just sig) (Just sig') | sig == defaultSignal && sig == sig'+-- On Windows, setting delegate_ctlc has no impact+runGenProcess_ fun c (Just sig) (Just sig') | isDefaultSignal sig && sig == sig' = createProcess_ fun c { delegate_ctlc = True } runGenProcess_ fun c _ _ = createProcess_ fun c-#else-runGenProcess_ fun c _ _ = createProcess_ fun c-#endif -#endif+-- ---------------------------------------------------------------------------+-- createPipe++-- | Create a pipe for interprocess communication and return a+-- @(readEnd, writeEnd)@ `Handle` pair.+--+-- @since 1.2.1.0+createPipe :: IO (Handle, Handle)+createPipe = createPipeInternal+{-# INLINE createPipe #-}+++-- ----------------------------------------------------------------------------+-- interruptProcessGroupOf++-- | Sends an interrupt signal to the process group of the given process.+--+-- On Unix systems, it sends the group the SIGINT signal.+--+-- On Windows systems, it generates a CTRL_BREAK_EVENT and will only work for+-- processes created using 'createProcess' and setting the 'create_group' flag++interruptProcessGroupOf+ :: ProcessHandle -- ^ A process in the process group+ -> IO ()+interruptProcessGroupOf = interruptProcessGroupOfInternal
+ System/Process/Posix.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+module System.Process.Posix+ ( mkProcessHandle+ , translateInternal+ , createProcess_Internal+ , withCEnvironment+ , closePHANDLE+ , startDelegateControlC+ , endDelegateControlC+ , stopDelegateControlC+ , isDefaultSignal+ , ignoreSignal+ , defaultSignal+ , c_execvpe+ , pPrPr_disableITimers+ , createPipeInternal+ , interruptProcessGroupOfInternal+ ) where++import Control.Concurrent+import Control.Exception+import Data.Bits+import Foreign.C+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import System.IO.Unsafe++import Control.Monad+import Data.Char+import System.IO+import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )+import System.Posix.Types++import System.Posix.Internals+import GHC.IO.Exception+import System.Posix.Signals as Sig+import qualified System.Posix.IO as Posix+import System.Posix.Process (getProcessGroupIDOf)++import System.Process.Common++#include "HsProcessConfig.h"+#include "processFlags.h"++mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle+mkProcessHandle p mb_delegate_ctlc = do+ m <- newMVar (OpenHandle p)+ return (ProcessHandle m mb_delegate_ctlc)++closePHANDLE :: PHANDLE -> IO ()+closePHANDLE _ = return ()++-- ----------------------------------------------------------------------------+-- commandToProcess++{- | Turns a shell command into a raw command. Usually this involves+ wrapping it in an invocation of the shell.++ There's a difference in the signature of commandToProcess between+ the Windows and Unix versions. On Unix, exec takes a list of strings,+ and we want to pass our command to /bin/sh as a single argument.++ On Windows, CreateProcess takes a single string for the command,+ which is later decomposed by cmd.exe. In this case, we just want+ to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line. The+ command-line translation that we normally do for arguments on+ Windows isn't required (or desirable) here.+-}++commandToProcess :: CmdSpec -> (FilePath, [String])+commandToProcess (ShellCommand string) = ("/bin/sh", ["-c", string])+commandToProcess (RawCommand cmd args) = (cmd, args)++translateInternal :: String -> String+translateInternal "" = "''"+translateInternal str+ -- goodChar is a pessimistic predicate, such that if an argument is+ -- non-empty and only contains goodChars, then there is no need to+ -- do any quoting or escaping+ | all goodChar str = str+ | otherwise = '\'' : foldr escape "'" str+ where escape '\'' = showString "'\\''"+ escape c = showChar c+ goodChar c = isAlphaNum c || c `elem` "-_.,/"++-- ----------------------------------------------------------------------------+-- Utils++withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a+withCEnvironment envir act =+ let env' = map (\(name, val) -> name ++ ('=':val)) envir+ in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)++-- -----------------------------------------------------------------------------+-- POSIX runProcess with signal handling in the child++createProcess_Internal+ :: String+ -> CreateProcess+ -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess_Internal fun+ CreateProcess{ cmdspec = cmdsp,+ cwd = mb_cwd,+ env = mb_env,+ std_in = mb_stdin,+ std_out = mb_stdout,+ std_err = mb_stderr,+ close_fds = mb_close_fds,+ create_group = mb_create_group,+ delegate_ctlc = mb_delegate_ctlc,+ detach_console = mb_detach_console,+ create_new_console = mb_create_new_console,+ new_session = mb_new_session,+ child_group = mb_child_group,+ child_user = mb_child_user }+ = do+ let (cmd,args) = commandToProcess cmdsp+ withFilePathException cmd $+ alloca $ \ pfdStdInput ->+ alloca $ \ pfdStdOutput ->+ alloca $ \ pfdStdError ->+ alloca $ \ pFailedDoing ->+ maybeWith withCEnvironment mb_env $ \pEnv ->+ maybeWith withFilePath mb_cwd $ \pWorkDir ->+ maybeWith with mb_child_group $ \pChildGroup ->+ maybeWith with mb_child_user $ \pChildUser ->+ withMany withFilePath (cmd:args) $ \cstrs ->+ withArray0 nullPtr cstrs $ \pargs -> do++ fdin <- mbFd fun fd_stdin mb_stdin+ fdout <- mbFd fun fd_stdout mb_stdout+ fderr <- mbFd fun fd_stderr mb_stderr++ when mb_delegate_ctlc+ startDelegateControlC++ -- runInteractiveProcess() blocks signals around the fork().+ -- Since blocking/unblocking of signals is a global state+ -- operation, we better ensure mutual exclusion of calls to+ -- runInteractiveProcess().+ proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->+ c_runInteractiveProcess pargs pWorkDir pEnv+ fdin fdout fderr+ pfdStdInput pfdStdOutput pfdStdError+ pChildGroup pChildUser+ (if mb_delegate_ctlc then 1 else 0)+ ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)+ .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)+ .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)+ .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)+ .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))+ pFailedDoing++ when (proc_handle == -1) $ do+ cFailedDoing <- peek pFailedDoing+ failedDoing <- peekCString cFailedDoing+ when mb_delegate_ctlc+ stopDelegateControlC+ throwErrno (fun ++ ": " ++ failedDoing)++ hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode+ hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode+ hndStdError <- mbPipe mb_stderr pfdStdError ReadMode++ ph <- mkProcessHandle proc_handle mb_delegate_ctlc+ return (hndStdInput, hndStdOutput, hndStdError, ph)++{-# NOINLINE runInteractiveProcess_lock #-}+runInteractiveProcess_lock :: MVar ()+runInteractiveProcess_lock = unsafePerformIO $ newMVar ()++-- ----------------------------------------------------------------------------+-- Delegated control-C handling on Unix++-- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301+-- and http://www.cons.org/cracauer/sigint.html+--+-- While running an interactive console process like ghci or a shell, we want+-- to let that process handle Ctl-C keyboard interrupts how it sees fit.+-- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're+-- running such programs. And then if/when they do terminate, we need to check+-- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we+-- got the Ctl-C then, by throwing the UserInterrupt exception.+--+-- If we run multiple programs like this concurrently then we have to be+-- careful to avoid messing up the signal handlers. We keep a count and only+-- restore when the last one has finished.++{-# NOINLINE runInteractiveProcess_delegate_ctlc #-}+runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler))+runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing++startDelegateControlC :: IO ()+startDelegateControlC =+ modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do+ case delegating of+ Nothing -> do+ -- We're going to ignore ^C in the parent while there are any+ -- processes using ^C delegation.+ --+ -- If another thread runs another process without using+ -- delegation while we're doing this then it will inherit the+ -- ignore ^C status.+ old_int <- installHandler sigINT Ignore Nothing+ old_quit <- installHandler sigQUIT Ignore Nothing+ return (Just (1, old_int, old_quit))++ Just (count, old_int, old_quit) -> do+ -- If we're already doing it, just increment the count+ let !count' = count + 1+ return (Just (count', old_int, old_quit))++stopDelegateControlC :: IO ()+stopDelegateControlC =+ modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do+ case delegating of+ Just (1, old_int, old_quit) -> do+ -- Last process, so restore the old signal handlers+ _ <- installHandler sigINT old_int Nothing+ _ <- installHandler sigQUIT old_quit Nothing+ return Nothing++ Just (count, old_int, old_quit) -> do+ -- Not the last, just decrement the count+ let !count' = count - 1+ return (Just (count', old_int, old_quit))++ Nothing -> return Nothing -- should be impossible++endDelegateControlC :: ExitCode -> IO ()+endDelegateControlC exitCode = do+ stopDelegateControlC++ -- And if the process did die due to SIGINT or SIGQUIT then+ -- we throw our equivalent exception here (synchronously).+ --+ -- An alternative design would be to throw to the main thread, as the+ -- normal signal handler does. But since we can be sync here, we do so.+ -- It allows the code locally to catch it and do something.+ case exitCode of+ ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt+ _ -> return ()+ where+ isSigIntQuit n = sig == sigINT || sig == sigQUIT+ where+ sig = fromIntegral (-n)++foreign import ccall unsafe "runInteractiveProcess"+ c_runInteractiveProcess+ :: Ptr CString+ -> CString+ -> Ptr CString+ -> FD+ -> FD+ -> FD+ -> Ptr FD+ -> Ptr FD+ -> Ptr FD+ -> Ptr CGid+ -> Ptr CUid+ -> CInt -- reset child's SIGINT & SIGQUIT handlers+ -> CInt -- flags+ -> Ptr CString+ -> IO PHANDLE++ignoreSignal, defaultSignal :: CLong+ignoreSignal = CONST_SIG_IGN+defaultSignal = CONST_SIG_DFL++isDefaultSignal :: CLong -> Bool+isDefaultSignal = (== defaultSignal)++createPipeInternal :: IO (Handle, Handle)+createPipeInternal = do+ (readfd, writefd) <- Posix.createPipe+ readh <- Posix.fdToHandle readfd+ writeh <- Posix.fdToHandle writefd+ return (readh, writeh)++interruptProcessGroupOfInternal+ :: ProcessHandle -- ^ A process in the process group+ -> IO ()+interruptProcessGroupOfInternal ph = do+ withProcessHandle ph $ \p_ -> do+ case p_ of+ ClosedHandle _ -> return ()+ OpenHandle h -> do+ pgid <- getProcessGroupIDOf h+ signalProcessGroup sigINT pgid
+ System/Process/Windows.hsc view
@@ -0,0 +1,283 @@+{-# LANGUAGE CPP #-}+module System.Process.Windows+ ( mkProcessHandle+ , translateInternal+ , createProcess_Internal+ , withCEnvironment+ , closePHANDLE+ , startDelegateControlC+ , endDelegateControlC+ , stopDelegateControlC+ , isDefaultSignal+ , createPipeInternal+ , interruptProcessGroupOfInternal+ ) where++import System.Process.Common+import Control.Concurrent+import Control.Exception+import Data.Bits+import Foreign.C+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import System.IO.Unsafe++import System.Posix.Internals+import GHC.IO.Exception+import GHC.IO.Handle.FD+import GHC.IO.Handle.Types hiding (ClosedHandle)+import System.IO.Error+import GHC.IO.IOMode++import System.Directory ( doesFileExist )+import System.Environment ( getEnv )+import System.FilePath+import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT)+import System.Win32.Process (getProcessId)++-- The double hash is used so that hsc does not process this include file+##include "processFlags.h"++#include <fcntl.h> /* for _O_BINARY */++throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE+throwErrnoIfBadPHandle = throwErrnoIfNull++-- On Windows, we have to close this HANDLE when it is no longer required,+-- hence we add a finalizer to it+mkProcessHandle :: PHANDLE -> IO ProcessHandle+mkProcessHandle h = do+ m <- newMVar (OpenHandle h)+ _ <- mkWeakMVar m (processHandleFinaliser m)+ return (ProcessHandle m False)++processHandleFinaliser :: MVar ProcessHandle__ -> IO ()+processHandleFinaliser m =+ modifyMVar_ m $ \p_ -> do+ case p_ of+ OpenHandle ph -> closePHANDLE ph+ _ -> return ()+ return (error "closed process handle")++closePHANDLE :: PHANDLE -> IO ()+closePHANDLE ph = c_CloseHandle ph++foreign import+#if defined(i386_HOST_ARCH)+ stdcall+#elif defined(x86_64_HOST_ARCH)+ ccall+#else+#error "Unknown architecture"+#endif+ unsafe "CloseHandle"+ c_CloseHandle+ :: PHANDLE+ -> IO ()++createProcess_Internal+ :: String -- ^ function name (for error messages)+ -> CreateProcess+ -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)++createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,+ cwd = mb_cwd,+ env = mb_env,+ std_in = mb_stdin,+ std_out = mb_stdout,+ std_err = mb_stderr,+ close_fds = mb_close_fds,+ create_group = mb_create_group,+ delegate_ctlc = _ignored,+ detach_console = mb_detach_console,+ create_new_console = mb_create_new_console,+ new_session = mb_new_session }+ = do+ (cmd, cmdline) <- commandToProcess cmdsp+ withFilePathException cmd $+ alloca $ \ pfdStdInput ->+ alloca $ \ pfdStdOutput ->+ alloca $ \ pfdStdError ->+ maybeWith withCEnvironment mb_env $ \pEnv ->+ maybeWith withCWString mb_cwd $ \pWorkDir -> do+ withCWString cmdline $ \pcmdline -> do++ fdin <- mbFd fun fd_stdin mb_stdin+ fdout <- mbFd fun fd_stdout mb_stdout+ fderr <- mbFd fun fd_stderr mb_stderr++ -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,+ -- because otherwise there is a race condition whereby one thread+ -- has created some pipes, and another thread spawns a process which+ -- accidentally inherits some of the pipe handles that the first+ -- thread has created.+ --+ -- An MVar in Haskell is the best way to do this, because there+ -- is no way to do one-time thread-safe initialisation of a mutex+ -- the C code. Also the MVar will be cheaper when not running+ -- the threaded RTS.+ proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->+ throwErrnoIfBadPHandle fun $+ c_runInteractiveProcess pcmdline pWorkDir pEnv+ fdin fdout fderr+ pfdStdInput pfdStdOutput pfdStdError+ ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)+ .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)+ .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)+ .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)+ .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))++ hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode+ hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode+ hndStdError <- mbPipe mb_stderr pfdStdError ReadMode++ ph <- mkProcessHandle proc_handle+ return (hndStdInput, hndStdOutput, hndStdError, ph)++{-# NOINLINE runInteractiveProcess_lock #-}+runInteractiveProcess_lock :: MVar ()+runInteractiveProcess_lock = unsafePerformIO $ newMVar ()++-- The following functions are always present in the export list. For+-- compatibility with the non-Windows code, we provide the same functions with+-- matching type signatures, but implemented as no-ops. For details, see:+-- <https://github.com/haskell/process/pull/21>+startDelegateControlC :: IO ()+startDelegateControlC = return ()++endDelegateControlC :: ExitCode -> IO ()+endDelegateControlC _ = return ()++stopDelegateControlC :: IO ()+stopDelegateControlC = return ()++-- End no-op functions++foreign import ccall unsafe "runInteractiveProcess"+ c_runInteractiveProcess+ :: CWString+ -> CWString+ -> Ptr CWString+ -> FD+ -> FD+ -> FD+ -> Ptr FD+ -> Ptr FD+ -> Ptr FD+ -> CInt -- flags+ -> IO PHANDLE++commandToProcess+ :: CmdSpec+ -> IO (FilePath, String)+commandToProcess (ShellCommand string) = do+ cmd <- findCommandInterpreter+ return (cmd, translateInternal cmd ++ " /c " ++ string)+ -- We don't want to put the cmd into a single+ -- argument, because cmd.exe will not try to split it up. Instead,+ -- we just tack the command on the end of the cmd.exe command line,+ -- 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)++-- 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+findCommandInterpreter = do+ -- try COMSPEC first+ catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)+ (getEnv "COMSPEC") $ \_ -> do++ -- try to find CMD.EXE or COMMAND.COM+ {-+ XXX We used to look at _osver (using cbits) and pick which shell to+ use with+ let filename | osver .&. 0x8000 /= 0 = "command.com"+ | otherwise = "cmd.exe"+ We ought to use GetVersionEx instead, but for now we just look for+ either filename+ -}+ path <- getEnv "PATH"+ let+ -- use our own version of System.Directory.findExecutable, because+ -- that assumes the .exe suffix.+ search :: [FilePath] -> IO (Maybe FilePath)+ search [] = return Nothing+ search (d:ds) = do+ let path1 = d </> "cmd.exe"+ path2 = d </> "command.com"+ b1 <- doesFileExist path1+ b2 <- doesFileExist path2+ if b1 then return (Just path1)+ else if b2 then return (Just path2)+ else search ds+ --+ mb_path <- search (splitSearchPath path)++ case mb_path of+ Nothing -> ioError (mkIOError doesNotExistErrorType+ "findCommandInterpreter" Nothing Nothing)+ Just cmd -> return cmd++translateInternal :: String -> String+translateInternal xs = '"' : snd (foldr escape (True,"\"") xs)+ where escape '"' (_, str) = (True, '\\' : '"' : str)+ escape '\\' (True, str) = (True, '\\' : '\\' : str)+ escape '\\' (False, str) = (False, '\\' : str)+ escape c (_, str) = (False, c : str)+ -- See long comment above for what this function is trying to do.+ --+ -- The Bool passed back along the string is True iff the+ -- rest of the string is a sequence of backslashes followed by+ -- a double quote.++withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a+withCEnvironment envir act =+ let env' = foldr (\(name, val) env0 -> name ++ ('=':val)++'\0':env0) "\0" envir+ in withCWString env' (act . castPtr)++isDefaultSignal :: CLong -> Bool+isDefaultSignal = const False++createPipeInternal :: IO (Handle, Handle)+createPipeInternal = do+ (readfd, writefd) <- allocaArray 2 $ \ pfds -> do+ throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)+ readfd <- peek pfds+ writefd <- peekElemOff pfds 1+ return (readfd, writefd)+ (do readh <- fdToHandle readfd+ writeh <- fdToHandle writefd+ return (readh, writeh)) `onException` (close' readfd >> close' writefd)++close' :: CInt -> IO ()+close' = throwErrnoIfMinus1_ "_close" . c__close++foreign import ccall "io.h _pipe" c__pipe ::+ Ptr CInt -> CUInt -> CInt -> IO CInt++foreign import ccall "io.h _close" c__close ::+ CInt -> IO CInt++interruptProcessGroupOfInternal+ :: ProcessHandle -- ^ A process in the process group+ -> IO ()+interruptProcessGroupOfInternal ph = do+ withProcessHandle ph $ \p_ -> do+ case p_ of+ ClosedHandle _ -> return ()+ OpenHandle h -> do+#if mingw32_HOST_OS+ pid <- getProcessId h+ generateConsoleCtrlEvent cTRL_BREAK_EVENT pid+-- We can't use an #elif here, because MIN_VERSION_unix isn't defined+-- on Windows, so on Windows cpp fails:+-- error: missing binary operator before token "("+#else+ pgid <- getProcessGroupIDOf h+ signalProcessGroup sigINT pgid+#endif+ return ()
changelog.md view
@@ -1,5 +1,11 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.4.1.0 *November 2015*++* Use less CPP [#47](https://github.com/haskell/process/pull/47)+ * Refactor to have separate Windows and POSIX modules internally+ * Remove the broken non-GHC code paths+ ## 1.4.0.0 *November 2015* * Added `child_user` and `child_group` to `CreateProcess` for unix. [#45](https://github.com/haskell/process/pull/45)
process.cabal view
@@ -1,5 +1,5 @@ name: process-version: 1.4.0.0+version: 1.4.1.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE@@ -44,9 +44,16 @@ exposed-modules: System.Cmd System.Process- if impl(ghc)- exposed-modules:- System.Process.Internals+ System.Process.Internals+ other-modules: System.Process.Common+ if os(windows)+ other-modules: System.Process.Windows+ build-depends: Win32 >=2.2 && < 2.4+ extra-libraries: kernel32+ cpp-options: -DWINDOWS+ else+ other-modules: System.Process.Posix+ build-depends: unix >= 2.5 && < 2.8 c-sources: cbits/runProcess.c@@ -63,11 +70,6 @@ directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.5, deepseq >= 1.1 && < 1.5- if os(windows)- build-depends: Win32 >=2.2 && < 2.4- extra-libraries: kernel32- else- build-depends: unix >= 2.5 && < 2.8 test-suite test default-language: Haskell2010