diff --git a/System/Process.hsc b/System/Process.hsc --- a/System/Process.hsc +++ b/System/Process.hsc @@ -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 /* for _close and _pipe */ -# include /* 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 diff --git a/System/Process/Common.hs b/System/Process/Common.hs new file mode 100644 --- /dev/null +++ b/System/Process/Common.hs @@ -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 + -- + -- 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 + -- + -- 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) diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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 - -- - -- 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 - -- - -- 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: --- -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 diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs new file mode 100644 --- /dev/null +++ b/System/Process/Posix.hs @@ -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 diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc new file mode 100644 --- /dev/null +++ b/System/Process/Windows.hsc @@ -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 /* 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: +-- +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 () diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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) diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -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