Commits (32)
/dist/
/.stack-work/
# Specific generated files
GNUmakefile
......
......@@ -7,6 +7,7 @@ env:
- GHCVER=7.6.3 CABALVER=1.16
- GHCVER=7.8.4 CABALVER=1.18
- GHCVER=7.10.1 CABALVER=1.22
- GHCVER=7.10.2 CABALVER=1.22
- GHCVER=head CABALVER=head
matrix:
......
......@@ -123,7 +123,12 @@ proc cmd args = CreateProcess { cmdspec = RawCommand cmd args,
std_err = Inherit,
close_fds = False,
create_group = False,
delegate_ctlc = False}
delegate_ctlc = False,
detach_console = False,
create_new_console = False,
new_session = False,
child_group = Nothing,
child_user = Nothing }
-- | Construct a 'CreateProcess' record for passing to 'createProcess',
-- representing a command to be passed to the shell.
......@@ -136,7 +141,12 @@ shell str = CreateProcess { cmdspec = ShellCommand str,
std_err = Inherit,
close_fds = False,
create_group = False,
delegate_ctlc = False}
delegate_ctlc = False,
detach_console = False,
create_new_console = False,
new_session = False,
child_group = Nothing,
child_user = Nothing }
{- |
This is the most general way to spawn an external process. The
......@@ -268,7 +278,7 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr,
-- arguments. It does not wait for the program to finish, but returns the
-- 'ProcessHandle'.
--
-- /Since: 1.2.0.0/
-- @since 1.2.0.0
spawnProcess :: FilePath -> [String] -> IO ProcessHandle
spawnProcess cmd args = do
(_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args)
......@@ -277,7 +287,7 @@ spawnProcess cmd args = do
-- | Creates a new process to run the specified shell command.
-- It does not wait for the program to finish, but returns the 'ProcessHandle'.
--
-- /Since: 1.2.0.0/
-- @since 1.2.0.0
spawnCommand :: String -> IO ProcessHandle
spawnCommand cmd = do
(_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd)
......@@ -292,11 +302,11 @@ spawnCommand cmd = do
-- exit code, an exception is raised.
--
-- If an asynchronous exception is thrown to the thread executing
-- @callProcess@. The forked process will be terminated and
-- @callProcess@, the forked process will be terminated and
-- @callProcess@ will wait (block) until the process has been
-- terminated.
--
-- /Since: 1.2.0.0/
-- @since 1.2.0.0
callProcess :: FilePath -> [String] -> IO ()
callProcess cmd args = do
exit_code <- withCreateProcess_ "callProcess"
......@@ -310,11 +320,11 @@ callProcess cmd args = do
-- command returns a non-zero exit code, an exception is raised.
--
-- If an asynchronous exception is thrown to the thread executing
-- @callCommand@. The forked process will be terminated and
-- @callCommand@, the forked process will be terminated and
-- @callCommand@ will wait (block) until the process has been
-- terminated.
--
-- /Since: 1.2.0.0/
-- @since 1.2.0.0
callCommand :: String -> IO ()
callCommand cmd = do
exit_code <- withCreateProcess_ "callCommand"
......@@ -424,7 +434,8 @@ readProcess cmd args = readCreateProcess $ proc cmd args
--
-- Note that @Handle@s provided for @std_in@ or @std_out@ via the CreateProcess
-- record will be ignored.
-- /Since: 1.2.3.0/
--
-- @since 1.2.3.0
readCreateProcess
:: CreateProcess
......@@ -493,7 +504,7 @@ readProcessWithExitCode cmd args =
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
-- record will be ignored.
--
-- /Since: 1.2.3.0/
-- @since 1.2.3.0
readCreateProcessWithExitCode
:: CreateProcess
-> String -- ^ standard input
......@@ -928,7 +939,7 @@ rawSystem cmd args = system (showCommandForUser cmd args)
-- | Create a pipe for interprocess communication and return a
-- @(readEnd, writeEnd)@ `Handle` pair.
--
-- /Since: 1.2.1.0/
-- @since 1.2.1.0
createPipe :: IO (Handle, Handle)
#if !mingw32_HOST_OS
createPipe = do
......
......@@ -59,6 +59,8 @@ 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__
......@@ -99,6 +101,13 @@ import System.FilePath
# 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
......@@ -177,11 +186,32 @@ data CreateProcess = CreateProcess{
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).
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/
-- @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
......@@ -213,7 +243,7 @@ data CmdSpec
-- | construct a `ShellCommand` from a string literal
--
-- /Since: 1.2.1.0/
-- @since 1.2.1.0
instance IsString CmdSpec where
fromString = ShellCommand
......@@ -224,6 +254,7 @@ data StdStream
-- @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:
......@@ -237,7 +268,7 @@ data StdStream
-- for some time, and is part of the "System.Process" module since version
-- 1.2.1.0.
--
-- /Since: 1.2.1.0/
-- @since 1.2.1.0
createProcess_
:: String -- ^ function name (for error messages)
-> CreateProcess
......@@ -258,7 +289,12 @@ createProcess_ fun CreateProcess{ cmdspec = cmdsp,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group,
delegate_ctlc = mb_delegate_ctlc }
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 $
......@@ -268,6 +304,8 @@ createProcess_ fun CreateProcess{ cmdspec = cmdsp,
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
......@@ -286,9 +324,13 @@ createProcess_ fun CreateProcess{ cmdspec = cmdsp,
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_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
......@@ -396,6 +438,8 @@ foreign import ccall unsafe "runInteractiveProcess"
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> Ptr CGid
-> Ptr CUid
-> CInt -- reset child's SIGINT & SIGQUIT handlers
-> CInt -- flags
-> Ptr CString
......@@ -419,7 +463,10 @@ createProcess_ fun CreateProcess{ cmdspec = cmdsp,
std_err = mb_stderr,
close_fds = mb_close_fds,
create_group = mb_create_group,
delegate_ctlc = _ignored }
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 $
......@@ -450,7 +497,10 @@ createProcess_ fun CreateProcess{ cmdspec = cmdsp,
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_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
......@@ -503,6 +553,7 @@ 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
......
......@@ -40,6 +40,10 @@ extern void unblockUserSignals(void);
#define forkChdirFailed 126
#define forkExecFailed 127
// These are arbitrarily chosen -- JP
#define forkSetgidFailed 124
#define forkSetuidFailed 125
__attribute__((__noreturn__))
static void childFailed(int pipe, int failCode) {
int err;
......@@ -57,6 +61,7 @@ runInteractiveProcess (char *const args[],
char *workingDirectory, char **environment,
int fdStdIn, int fdStdOut, int fdStdErr,
int *pfdStdInput, int *pfdStdOutput, int *pfdStdError,
gid_t *childGroup, uid_t *childUser,
int reset_int_quit_handlers,
int flags,
char **failed_doing)
......@@ -138,9 +143,26 @@ runInteractiveProcess (char *const args[],
close(forkCommunicationFds[0]);
fcntl(forkCommunicationFds[1], F_SETFD, FD_CLOEXEC);
if ((flags & RUN_PROCESS_NEW_SESSION) != 0) {
setsid();
}
if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) {
setpgid(0, 0);
}
if ( childGroup) {
if ( setgid( *childGroup) != 0) {
// ERROR
childFailed(forkCommunicationFds[1], forkSetgidFailed);
}
}
if ( childUser) {
if ( setuid( *childUser) != 0) {
// ERROR
childFailed(forkCommunicationFds[1], forkSetuidFailed);
}
}
unblockUserSignals();
......@@ -162,6 +184,8 @@ runInteractiveProcess (char *const args[],
close(fdStdInput[0]);
}
close(fdStdInput[1]);
} else if (fdStdIn == -2) {
close(STDIN_FILENO);
} else {
dup2(fdStdIn, STDIN_FILENO);
}
......@@ -172,6 +196,8 @@ runInteractiveProcess (char *const args[],
close(fdStdOutput[1]);
}
close(fdStdOutput[0]);
} else if (fdStdOut == -2) {
close(STDOUT_FILENO);
} else {
dup2(fdStdOut, STDOUT_FILENO);
}
......@@ -182,6 +208,8 @@ runInteractiveProcess (char *const args[],
close(fdStdError[1]);
}
close(fdStdError[0]);
} else if (fdStdErr == -2) {
close(STDERR_FILENO);
} else {
dup2(fdStdErr, STDERR_FILENO);
}
......@@ -272,6 +300,11 @@ runInteractiveProcess (char *const args[],
case forkExecFailed:
*failed_doing = "runInteractiveProcess: exec";
break;
case forkSetgidFailed:
*failed_doing = "runInteractiveProcess: setgid";
break;
case forkSetuidFailed:
*failed_doing = "runInteractiveProcess: setuid";
default:
*failed_doing = "runInteractiveProcess: unknown";
break;
......@@ -481,6 +514,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE))
goto cleanup_err;
sInfo.hStdInput = hStdInputRead;
} else if (fdStdIn == -2) {
sInfo.hStdInput = NULL;
} else if (fdStdIn == 0) {
// Don't duplicate stdin, as console handles cannot be
// duplicated and inherited. urg.
......@@ -501,6 +536,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE))
goto cleanup_err;
sInfo.hStdOutput = hStdOutputWrite;
} else if (fdStdOut == -2) {
sInfo.hStdOutput = NULL;
} else if (fdStdOut == 1) {
// Don't duplicate stdout, as console handles cannot be
// duplicated and inherited. urg.
......@@ -521,6 +558,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
if (!mkAnonPipe(&hStdErrorRead, TRUE, &hStdErrorWrite, TRUE))
goto cleanup_err;
sInfo.hStdError = hStdErrorWrite;
} else if (fdStdErr == -2) {
sInfo.hStdError = NULL;
} else if (fdStdErr == 2) {
// Don't duplicate stderr, as console handles cannot be
// duplicated and inherited. urg.
......@@ -553,6 +592,12 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) {
dwFlags |= CREATE_NEW_PROCESS_GROUP;
}
if ((flags & RUN_PROCESS_DETACHED) != 0) {
dwFlags |= DETACHED_PROCESS;
}
if ((flags & RUN_PROCESS_NEW_CONSOLE) != 0) {
dwFlags |= CREATE_NEW_CONSOLE;
}
if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo))
{
......
# Changelog for [`process` package](http://hackage.haskell.org/package/process)
## 1.4.0.0 *unreleased*
* Added `child_user` and `child_group` to `CreateProcess` for unix. [#45](https://github.com/haskell/process/pull/45)
## 1.3.0.0 *August 2015*
* Add `StdStream(NoStream)` to have standard handles closed. [#13](https://github.com/haskell/process/pull/13)
* Support for Windows `DETACHED_PROCESS` and `setsid` [#32](https://github.com/haskell/process/issues/32)
* Support for Windows `CREATE_NEW_CONSOLE` [#38](https://github.com/haskell/process/issues/38)
## 1.2.3.0 *March 2015*
* [Meaningful error message when exe not found on close\_fds is
......
......@@ -6,3 +6,6 @@
#define RUN_PROCESS_IN_CLOSE_FDS 0x1
#define RUN_PROCESS_IN_NEW_GROUP 0x2
#define RUN_PROCESS_DETACHED 0x4
#define RUN_PROCESS_NEW_SESSION 0x8
#define RUN_PROCESS_NEW_CONSOLE 0x10
......@@ -62,6 +62,8 @@ extern ProcHandle runInteractiveProcess( char *const args[],
int *pfdStdInput,
int *pfdStdOutput,
int *pfdStdError,
gid_t *childGroup,
uid_t *childUser,
int reset_int_quit_handlers,
int flags,
char **failed_doing);
......
name: process
version: 1.2.3.0
version: 1.3.0.1
-- NOTE: Don't forget to update ./changelog.md
license: BSD3
license-file: LICENSE
......@@ -59,7 +59,7 @@ library
ghc-options: -Wall
build-depends: base >= 4.4 && < 4.9,
build-depends: base >= 4.4 && < 4.10,
directory >= 1.1 && < 1.3,
filepath >= 1.2 && < 1.5,
deepseq >= 1.1 && < 1.5
......
resolver: ghc-7.10.2
import Control.Exception
import System.Exit
import System.IO.Error
import System.Process
......@@ -12,3 +13,18 @@ main = do
case res of
Left True -> return ()
_ -> error $ show res
let test name modifier = do
putStrLn $ "Running test: " ++ name
(_, _, _, ph) <- createProcess
$ modifier $ proc "echo" ["hello", "world"]
ec <- waitForProcess ph
if ec == ExitSuccess
then putStrLn $ "Success running: " ++ name
else error $ "echo returned: " ++ show ec
test "detach_console" $ \cp -> cp { detach_console = True }
test "create_new_console" $ \cp -> cp { create_new_console = True }
test "new_session" $ \cp -> cp { new_session = True }
putStrLn "Tests passed successfully"