Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • AndreasK/process
  • Haskell-mouse/process
  • supersven/process
3 results
Show changes
Commits on Source (222)
122 additional commits have been omitted to prevent performance issues.
Hide whitespace changes
Inline Side-by-side
Showing
with 1989 additions and 363 deletions
.github/workflows/tests.yml 0 → 100644
View file @ 98101f82
name: Tests
on:
pull_request:
push:
branches:
- '**'
jobs:
build:
name: GHC ${{ matrix.ghc-version }} on ${{ matrix.platform.arch }} ${{ matrix.platform.os }}
runs-on: ${{ matrix.platform.os }}
strategy:
fail-fast: false
matrix:
platform:
- { os: ubuntu-latest, arch: x64 }
- { os: macos-13, arch: x64 }
- { os: macos-14, arch: arm }
- { os: windows-latest, arch: x64 }
ghc-version:
- 'latest'
- '9.10'
- '9.8'
- '9.6'
- '9.4'
- '9.2'
- '9.0'
- '8.10'
- '8.8'
- '8.6'
exclude:
# Only allow ARM jobs with GHC >= 9.2
# (It's tedious to not be able to use matrix.ghc-version >= 9.2 as a conditional here.)
- platform:
arch: arm
ghc-version: '9.0'
- platform:
arch: arm
ghc-version: '8.10'
- platform:
arch: arm
ghc-version: '8.8'
- platform:
arch: arm
ghc-version: '8.6'
steps:
- uses: actions/checkout@v4
- name: Set up GHC ${{ matrix.ghc-version }}
uses: haskell-actions/setup@v2
id: setup
with:
ghc-version: ${{ matrix.ghc-version }}
# Defaults, added for clarity:
cabal-version: 'latest'
cabal-update: true
- name: Set up autotools (Darwin)
if: ${{ runner.os == 'macOS' }}
run: brew install autoconf
- name: Set up autotools (Windows)
if: ${{ runner.os == 'Windows' }}
uses: msys2/setup-msys2@v2
with:
update: true
install: >-
autotools
- name: Run autoreconf (Windows)
if: ${{ runner.os == 'Windows' }}
run: autoreconf -i
shell: "msys2 {0}"
- name: Run autoreconf (Linux & Mac)
if: ${{ runner.os != 'Windows' }}
run: autoreconf -i
- name: Configure the build
run: |
cabal configure --enable-tests --enable-benchmarks --disable-documentation
cabal build all --dry-run
# The last step generates dist-newstyle/cache/plan.json for the cache key.
- name: Restore cached dependencies
uses: actions/cache/restore@v3
id: cache
env:
key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}
restore-keys: ${{ env.key }}-
- name: Install dependencies
# If we had an exact cache hit, the dependencies will be up to date.
if: steps.cache.outputs.cache-hit != 'true'
run: cabal build process --only-dependencies
# Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.
- name: Save cached dependencies
uses: actions/cache/save@v3
# If we had an exact cache hit, trying to save the cache would error because of key clash.
if: steps.cache.outputs.cache-hit != 'true'
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ steps.cache.outputs.cache-primary-key }}
- name: Build
run: cabal build process
- name: Run tests
run: cabal run process-tests:test
# On Windows and with GHC >= 9.0, re-run the test-suite using WinIO.
- name: Re-run tests with WinIO (Windows && GHC >= 9.0)
if: ${{ runner.os == 'Windows' && matrix.ghc-version >= '9.0' }}
run: cabal run process-tests:test -- +RTS --io-manager=native -RTS
- name: Source dist
run: cabal sdist all --ignore-project
- name: Build documentation
run: cabal haddock process
- name: Check process.cabal
run: cabal check
- name: Check process-tests.cabal
working-directory: ./test
run: cabal check
.gitignore
View file @ 98101f82
/.cabal-sandbox/
/cabal.project.local
/cabal.sandbox.config
/dist/
/dist-newstyle/
/.stack-work/
**/.cabal-sandbox/
**/cabal.project.local
**/cabal.sandbox.config
**/dist/
**/dist-newstyle/
**/.stack-work/
*.swp
stack.yaml.lock
# Specific generated files
GNUmakefile
......@@ -20,3 +21,6 @@ tests/exitminus1
tests/exitminus1.o
tests/foo1.txt
tests/foo2.txt
# IDEs
.vscode
.travis.yml deleted 100644 → 0
View file @ f295998c
# This is the complex Travis configuration, which is intended for use
# on open source libraries which need compatibility across multiple GHC
# versions, must work with cabal-install, and should be
# cross-platform. For more information and other options, see:
#
# https://docs.haskellstack.org/en/stable/travis_ci/
#
# Copy these contents into the root directory of your Github project in a file
# named .travis.yml
# Use new container infrastructure to enable caching
sudo: false
# Do not choose a language; we provide our own build tools.
language: generic
# Caching so the next build will be fast too.
cache:
directories:
- $HOME/.ghc
- $HOME/.cabal
- $HOME/.stack
- $TRAVIS_BUILD_DIR/.stack-work
# The different configurations we want to test. We have BUILD=cabal which uses
# cabal-install, and BUILD=stack which uses Stack. More documentation on each
# of those below.
#
# We set the compiler values here to tell Travis to use a different
# cache file per set of arguments.
#
# If you need to have different apt packages for each combination in the
# matrix, you can use a line such as:
# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}
matrix:
include:
# We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
# https://github.com/hvr/multi-ghc-travis
- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 7.10.3"
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.0.2"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.2.2"
addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.4.4"
addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.6.5"
addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
# Build with the newest GHC and cabal-install. This is an accepted failure,
# see below.
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC HEAD"
addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
# The Stack builds. We can pass in arbitrary Stack arguments via the ARGS
# variable, such as using --stack-yaml to point to a different file.
- env: BUILD=stack ARGS=""
compiler: ": #stack default"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 8.0.1"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-11"
compiler: ": #stack 8.2.2"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-12"
compiler: ": #stack 8.4.4"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-13"
compiler: ": #stack 8.6.5"
addons: {apt: {packages: [libgmp-dev]}}
# Nightly builds are allowed to fail
- env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly"
addons: {apt: {packages: [libgmp-dev]}}
# Build on macOS in addition to Linux
- env: BUILD=stack ARGS=""
compiler: ": #stack default osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 8.0.1 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-11"
compiler: ": #stack 8.2.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-12"
compiler: ": #stack 8.4.4 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-13"
compiler: ": #stack 8.6.5 osx"
os: osx
- env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly osx"
os: osx
allow_failures:
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
before_install:
# Using compiler above sets CC to an invalid value, so unset it
- unset CC
# We want to always allow newer versions of packages when building on GHC HEAD
- CABALARGS=""
- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi
# Download and unpack the stack executable
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH
- mkdir -p ~/.local/bin
- |
if [ `uname` = "Darwin" ]
then
travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
else
travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
fi
# Use the more reliable S3 mirror of Hackage
mkdir -p $HOME/.cabal
echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config
echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config
install:
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- if [ -f configure.ac ]; then autoreconf -i; fi
- |
set -ex
case "$BUILD" in
stack)
stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies --pedantic
;;
cabal)
cabal --version
travis_retry cabal update
# Get the list of packages from the stack.yaml file
PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
;;
esac
set +ex
script:
- |
set -ex
case "$BUILD" in
stack)
stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
;;
cabal)
cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
ORIGDIR=$(pwd)
for dir in $PACKAGES
do
cd $dir
cabal check || [ "$CABALVER" == "1.16" ]
cabal sdist
PKGVER=$(cabal info . | awk '{print $2;exit}')
SRC_TGZ=$PKGVER.tar.gz
cd dist
tar zxfv "$SRC_TGZ"
cd "$PKGVER"
cabal configure --enable-tests --ghc-options -O0
cabal build
if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then
cabal test
else
cabal test --show-details=streaming --log=/dev/stdout
fi
cd $ORIGDIR
done
;;
esac
set +ex
README.md
View file @ 98101f82
The `process` Package [![Hackage](https://img.shields.io/hackage/v/process.svg)](https://hackage.haskell.org/package/process) [![Build Status](https://travis-ci.org/haskell/process.svg)](https://travis-ci.org/haskell/process) [![Windows build status](https://ci.appveyor.com/api/projects/status/0o4c3w99frtxyrht?svg=true)](https://ci.appveyor.com/project/snoyberg/process)
The `process` Package [![Hackage](https://img.shields.io/hackage/v/process.svg)](https://hackage.haskell.org/package/process) ![Tests](https://github.com/haskell/process/workflows/Tests/badge.svg)
=====================
See [`process` on Hackage](http://hackage.haskell.org/package/process) for
......
Setup.hs
View file @ 98101f82
module Main (main) where
-- Cabal
import Distribution.Simple
( defaultMainWithHooks
, autoconfUserHooks
)
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMainWithHooks autoconfUserHooks
System/Process.hs
View file @ 98101f82
......@@ -6,6 +6,12 @@
#endif
{-# LANGUAGE InterruptibleFFI #-}
#include <ghcplatform.h>
#if defined(javascript_HOST_ARCH)
{-# LANGUAGE JavaScriptFFI #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Process
......@@ -20,7 +26,7 @@
--
-----------------------------------------------------------------------------
-- ToDo:
-- TODO:
-- * Flag to control whether exiting the parent also kills the child.
module System.Process (
......@@ -49,6 +55,10 @@ module System.Process (
showCommandForUser,
Pid,
getPid,
getCurrentPid,
-- ** Secure process creation on Windows
-- $windows-mitigations
-- ** Control-C handling on Unix
-- $ctlc-handling
......@@ -82,7 +92,11 @@ import System.Process.Internals
import Control.Concurrent
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, mask, allowInterrupt, bracket, try, throwIO)
import Control.Exception (
#if !defined(javascript_HOST_ARCH)
allowInterrupt,
#endif
bracket)
import qualified Control.Exception as C
import Control.Monad
import Data.Maybe
......@@ -92,20 +106,30 @@ import System.Exit ( ExitCode(..) )
import System.IO
import System.IO.Error (mkIOError, ioeSetErrorString)
#if defined(WINDOWS)
import System.Win32.Process (getProcessId, ProcessId)
#if defined(javascript_HOST_ARCH)
import System.Process.JavaScript(getProcessId, getCurrentProcessId)
#elif defined(mingw32_HOST_OS)
import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId)
#else
import System.Posix.Process (getProcessID)
import System.Posix.Types (CPid (..))
#endif
import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )
import GHC.IO.Exception ( ioException, IOErrorType(..) )
#if defined(wasm32_HOST_ARCH)
import GHC.IO.Exception ( unsupportedOperation )
import System.IO.Error
#endif
-- | The platform specific type for a process identifier.
--
-- This is always an integral type. Width and signedness are platform specific.
--
-- @since 1.6.3.0
#if defined(WINDOWS)
#if defined(javascript_HOST_ARCH)
type Pid = Int
#elif defined(mingw32_HOST_OS)
type Pid = ProcessId
#else
type Pid = CPid
......@@ -256,10 +280,10 @@ withCreateProcess_ fun c action =
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-- | Cleans up the process.
--
-- This function is meant to be invoked from any application level cleanup
--
-- This function is meant to be invoked from any application level cleanup
-- handler. It terminates the process, and closes any 'CreatePipe' 'handle's.
--
--
-- @since 1.6.4.0
cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
......@@ -358,6 +382,39 @@ processFailedException fun cmd args exit_code =
Nothing Nothing)
-- ----------------------------------------------------------------------------
-- Secure process creation on Windows
-- $windows-migitations
--
-- In general it is strongly advised that any untrusted user input be validated before
-- being passed to a subprocess. One must be especially careful on Windows due to the
-- crude nature of the platform's argument passing scheme. Specifically, unlike POSIX
-- platforms, Windows treats the command-line not as a sequence of arguments but rather
-- as a single string. It is therefore the responsibility of the called process to tokenize
-- this string into distinct arguments.
--
-- While various programs on Windows tend to differ in their precise argument splitting
-- behavior, the scheme used by @process@'s 'RawCommand' 'CmdSpec' should work for
-- most reasonable programs. If you find that 'RawCommand' doesn't provide
-- the behavior you need, it is recommended to instead compose your command-line
-- manually and rather using the 'shell' 'CmdSpec'.
--
-- Additionally, the idiosyncratic escaping and string interpolation behavior of
-- the Windows @cmd.exe@ command interpreter is known to introduce considerable
-- complication to secure process creation. For this reason, @process@ implements
-- specific argument escaping logic when the executable's file extension suggests
-- that it is a batch file (e.g. @.bat@ or @.cmd@). However, this is not a
-- completely reliable mitigation as Windows will also silently execute batch files
-- when starting executables lacking a file extension (e.g. @callProcess "hello" []@
-- when a @hello.bat@ is present in @PATH@). For this reason, users are encouraged to
-- specify the file extension of invoked executables where possible, especially
-- when untrusted input is involved.
--
-- Users passed untrusted input to subprocesses on Windows are encouraged to review
-- <https://flatt.tech/research/posts/batbadbut-you-cant-securely-execute-commands-on-windows/>
-- for guidance on how to safely navigate these waters.
-- ----------------------------------------------------------------------------
-- Control-C handling on Unix
......@@ -381,7 +438,7 @@ processFailedException fun cmd args exit_code =
-- @SIGINT@ to every process using the console. The standard solution is that
-- while running an interactive program, ignore @SIGINT@ in the parent, and let
-- it be handled in the child process. If that process then terminates due to
-- the @SIGINT@ signal, then at that point treat it as if we had recieved the
-- the @SIGINT@ signal, then at that point treat it as if we had received the
-- @SIGINT@ ourselves and begin an orderly shutdown.
--
-- This behaviour is implemented by 'createProcess' (and
......@@ -457,7 +514,8 @@ processFailedException fun cmd args exit_code =
--
-- * The command to run, which must be in the $PATH, or an absolute or relative path
--
-- * A list of separate command line arguments to the program
-- * A list of separate command line arguments to the program. See 'RawCommand' for
-- further discussion of Windows semantics.
--
-- * A string to pass on standard input to the forked process.
--
......@@ -595,28 +653,6 @@ readCreateProcessWithExitCode cp input = do
(_,Nothing,_) -> error "readCreateProcessWithExitCode: Failed to get a stdout handle."
(_,_,Nothing) -> error "readCreateProcessWithExitCode: Failed to get a stderr handle."
-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return
restore (body wait) `C.onException` killThread tid
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = C.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
-- ----------------------------------------------------------------------------
-- showCommandForUser
......@@ -642,7 +678,11 @@ getPid :: ProcessHandle -> IO (Maybe Pid)
getPid (ProcessHandle mh _ _) = do
p_ <- readMVar mh
case p_ of
#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
OpenHandle h -> do
pid <- getProcessId h
return $ Just pid
#elif defined(mingw32_HOST_OS)
OpenHandle h -> do
pid <- getProcessId h
return $ Just pid
......@@ -652,10 +692,31 @@ getPid (ProcessHandle mh _ _) = do
_ -> return Nothing
-- ----------------------------------------------------------------------------
-- getCurrentPid
-- | Returns the PID (process ID) of the current process. On POSIX systems,
-- this calls 'getProcessID' from "System.Posix.Process" in the @unix@ package.
-- On Windows, this calls 'getCurrentProcessId' from "System.Win32.Process" in
-- the @Win32@ package.
--
-- @since 1.6.12.0
getCurrentPid :: IO Pid
getCurrentPid =
#if defined(javascript_HOST_ARCH)
getCurrentProcessId
#elif defined(mingw32_HOST_OS)
getCurrentProcessId
#else
getProcessID
#endif
-- ----------------------------------------------------------------------------
-- waitForProcess
{- | Waits for the specified process to terminate, and returns its exit code.
On Unix systems, may throw 'UserInterrupt' when using 'delegate_ctlc'.
GHC Note: in order to call @waitForProcess@ without blocking all the
other threads in the system, you must compile the program with
......@@ -663,7 +724,8 @@ other threads in the system, you must compile the program with
Note that it is safe to call @waitForProcess@ for the same process in multiple
threads. When the process ends, threads blocking on this call will wake in
FIFO order.
FIFO order. When using 'delegate_ctlc' and the process is interrupted, only
the first waiting thread will throw 'UserInterrupt'.
(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@
indicates that the child was terminated by signal @/signum/@.
......@@ -683,17 +745,19 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
OpenHandle h -> do
-- don't hold the MVar while we call c_waitForProcess...
e <- waitForProcess' h
e' <- modifyProcessHandle ph $ \p_' ->
(e', was_open) <- modifyProcessHandle ph $ \p_' ->
case p_' of
ClosedHandle e' -> return (p_', e')
ClosedHandle e' -> return (p_', (e', False))
OpenExtHandle{} -> fail "waitForProcess(OpenExtHandle): this cannot happen"
OpenHandle ph' -> do
closePHANDLE ph'
when delegating_ctlc $
endDelegateControlC e
return (ClosedHandle e, e)
return (ClosedHandle e, (e, True))
-- endDelegateControlC after closing the handle, since it
-- may throw UserInterrupt
when (was_open && delegating_ctlc) $
endDelegateControlC e
return e'
#if defined(WINDOWS)
#if defined(mingw32_HOST_OS)
OpenExtHandle h job -> do
-- First wait for completion of the job...
waitForJobCompletion job
......@@ -705,9 +769,8 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
OpenExtHandle ph' job' -> do
closePHANDLE ph'
closePHANDLE job'
when delegating_ctlc $
endDelegateControlC e
return (ClosedHandle e, e)
-- omit endDelegateControlC since it's a no-op on Windows
return e'
#else
OpenExtHandle _ _job ->
......@@ -723,7 +786,11 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
waitForProcess' :: PHANDLE -> IO ExitCode
waitForProcess' h = alloca $ \pret -> do
#if defined(javascript_HOST_ARCH)
throwErrnoIfMinus1Retry_ "waitForProcess" (C.interruptible $ c_waitForProcess h pret)
#else
throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
#endif
mkExitCode <$> peek pret
mkExitCode :: CInt -> ExitCode
......@@ -741,7 +808,8 @@ still running, 'Nothing' is returned. If the process has exited, then
@'Just' e@ is returned where @e@ is the exit code of the process.
On Unix systems, see 'waitForProcess' for the meaning of exit codes
when the process died as the result of a signal.
when the process died as the result of a signal. May throw
'UserInterrupt' when using 'delegate_ctlc'.
-}
getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
......@@ -764,6 +832,8 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do
let e | code == 0 = ExitSuccess
| otherwise = ExitFailure (fromIntegral code)
return (ClosedHandle e, (Just e, True))
-- endDelegateControlC after closing the handle, since it
-- may throw UserInterrupt
case m_e of
Just e | was_open && delegating_ctlc -> endDelegateControlC e
_ -> return ()
......@@ -816,7 +886,7 @@ terminateProcess ph = do
withProcessHandle ph $ \p_ ->
case p_ of
ClosedHandle _ -> return ()
#if defined(WINDOWS)
#if defined(mingw32_HOST_OS)
OpenExtHandle{} -> terminateJobUnsafe p_ 1 >> return ()
#else
OpenExtHandle{} -> error "terminateProcess with OpenExtHandle should not happen on POSIX."
......@@ -831,6 +901,38 @@ terminateProcess ph = do
-- ----------------------------------------------------------------------------
-- Interface to C bits
#if defined(wasm32_HOST_ARCH)
c_terminateProcess :: PHANDLE -> IO CInt
c_terminateProcess _ = ioError (ioeSetLocation unsupportedOperation "terminateProcess")
c_getProcessExitCode :: PHANDLE -> Ptr CInt -> IO CInt
c_getProcessExitCode _ _ = ioError (ioeSetLocation unsupportedOperation "getProcessExitCode")
c_waitForProcess :: PHANDLE -> Ptr CInt -> IO CInt
c_waitForProcess _ _ = ioError (ioeSetLocation unsupportedOperation "waitForProcess")
#elif defined(javascript_HOST_ARCH)
foreign import javascript unsafe "h$process_terminateProcess"
c_terminateProcess
:: PHANDLE
-> IO Int
foreign import javascript unsafe "h$process_getProcessExitCode"
c_getProcessExitCode
:: PHANDLE
-> Ptr Int
-> IO Int
foreign import javascript interruptible "h$process_waitForProcess"
c_waitForProcess
:: PHANDLE
-> Ptr CInt
-> IO CInt
#else
foreign import ccall unsafe "terminateProcess"
c_terminateProcess
:: PHANDLE
......@@ -848,6 +950,7 @@ foreign import ccall interruptible "waitForProcess" -- NB. safe - can block
-> Ptr CInt
-> IO CInt
#endif
-- ----------------------------------------------------------------------------
-- Old deprecated variants
......
System/Process/Common.hs
View file @ 98101f82
......@@ -19,27 +19,31 @@ module System.Process.Common
, mbFd
, mbPipe
, pfdToHandle
, rawFdToHandle
-- Avoid a warning on Windows
#ifdef WINDOWS
#if defined(mingw32_HOST_OS)
, CGid (..)
#else
, CGid
#endif
-- WINIO is only available on GHC 8.12 and up.
#if defined(__IO_MANAGER_WINIO__)
#if defined(mingw32_HOST_OS)
, HANDLE
-- WINIO is only available on GHC 9.0 and up.
# if defined(__IO_MANAGER_WINIO__)
, mbHANDLE
, mbPipeHANDLE
, rawHANDLEToHandle
# endif
#endif
) where
import Control.Concurrent
import Control.Exception
import Data.String
import Data.String ( IsString(..) )
import Foreign.Ptr
import Foreign.Storable
import Foreign.Storable ( Storable(peek) )
import System.Posix.Internals
import GHC.IO.Exception
......@@ -57,9 +61,13 @@ import System.IO.Error
import Data.Typeable
import System.IO (IOMode)
#if defined(javascript_HOST_ARCH)
import GHC.JS.Prim (JSVal)
#endif
-- We do a minimal amount of CPP here to provide uniform data types across
-- Windows and POSIX.
#ifdef WINDOWS
#if defined(mingw32_HOST_OS)
import Data.Word (Word32)
import System.Win32.DebugApi (PHANDLE)
#if defined(__IO_MANAGER_WINIO__)
......@@ -69,7 +77,9 @@ import System.Win32.Types (HANDLE)
import System.Posix.Types
#endif
#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
type PHANDLE = JSVal
#elif defined(mingw32_HOST_OS)
-- Define some missing types for Windows compatibility. Note that these values
-- will never actually be used, as the setuid/setgid system calls are not
-- applicable on Windows. No value of this type will ever exist.
......@@ -80,7 +90,6 @@ type UserID = CGid
#else
type PHANDLE = CPid
#endif
data CreateProcess = CreateProcess{
cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command. If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory. If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability.
cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process
......@@ -88,11 +97,10 @@ data CreateProcess = CreateProcess{
std_in :: StdStream, -- ^ How to determine stdin
std_out :: StdStream, -- ^ How to determine stdout
std_err :: StdStream, -- ^ How to determine stderr
close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close an every fd from 3 to the maximum of open files, which can be slow for high maximum of open files.
create_group :: Bool, -- ^ Create a new process group
-- XXX verify what happens with fds in nodejs child processes
close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files.
create_group :: Bool, -- ^ Create a new process group. On JavaScript this also creates a new session.
delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).
--
-- 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.
......@@ -103,15 +111,15 @@ data CreateProcess = CreateProcess{
-- 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.
new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; starts process in a new session on JavaScript; 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.
child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; works for JavaScript when system running nodejs is posix. 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.
child_user :: Maybe UserID, -- ^ Use posix setuid to set child process's user id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.
--
-- Default: @Nothing@
--
......@@ -157,6 +165,14 @@ data CmdSpec
-- see the
-- <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365527%28v=vs.85%29.aspx documentation>
-- for the Windows @SearchPath@ API.
--
-- Windows does not have a mechanism for passing multiple arguments.
-- When using @RawCommand@ on Windows, the command line is serialised
-- into a string, with arguments quoted separately. Command line
-- parsing is up individual programs, so the default behaviour may
-- not work for some programs. If you are not getting the desired
-- results, construct the command line yourself and use 'ShellCommand'.
--
deriving (Show, Eq)
......@@ -190,6 +206,9 @@ data StdStream
-- ProcessHandle type
data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE }
-- | 'OpenExtHandle' is only applicable for
-- Windows platform. It represents [Job
-- Objects](https://learn.microsoft.com/en-us/windows/win32/procthread/job-objects).
| OpenExtHandle { phdlProcessHandle :: PHANDLE
-- ^ the process
, phdlJobHandle :: PHANDLE
......@@ -242,12 +261,17 @@ 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,..} ->
withHandle fun hdl $ \Handle__{haDevice=dev,..} -> do
case cast dev of
Just fd -> do
#if !defined(javascript_HOST_ARCH)
-- 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
#else
-- on the JavaScript platform we cannot change the FD flags
fd' <- pure fd
#endif
return (Handle__{haDevice=fd',..}, FD.fdFD fd')
Nothing ->
ioError (mkIOError illegalOperationErrorType
......@@ -259,8 +283,11 @@ 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
pfdToHandle pfd mode =
( \ fd -> rawFdToHandle fd mode ) =<< peek pfd
rawFdToHandle :: FD -> IOMode -> IO Handle
rawFdToHandle fd mode = do
let filepath = "fd:" ++ show fd
(fD,fd_type) <- FD.mkFD (fromIntegral fd) mode
(Just (Stream,0,0)) -- avoid calling fstat()
......@@ -274,6 +301,11 @@ pfdToHandle pfd mode = do
#endif
mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)
#if defined(mingw32_HOST_OS) && !defined(__IO_MANAGER_WINIO__)
type HANDLE = Ptr ()
#endif
#if defined(__IO_MANAGER_WINIO__)
-- It is not completely safe to pass the values -1 and -2 as HANDLE as it's an
-- unsigned type. -1 additionally is also the value for INVALID_HANDLE. However
......@@ -288,10 +320,14 @@ mbHANDLE _std NoStream = return $ intPtrToPtr (-2)
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl
mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
mbPipeHANDLE CreatePipe pfd mode =
do raw_handle <- peek pfd
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
ident = "hwnd:" ++ show raw_handle
Just <$> mkHandleFromHANDLE hwnd Stream ident mode Nothing
mbPipeHANDLE CreatePipe pfd mode =
Just <$> ( ( \ hANDLE -> rawHANDLEToHandle hANDLE mode ) =<< peek pfd )
mbPipeHANDLE _std _pfd _mode = return Nothing
rawHANDLEToHandle :: HANDLE -> IOMode-> IO Handle
rawHANDLEToHandle raw_handle mode = do
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
ident = "hwnd:" ++ show raw_handle
enc <- getLocaleEncoding
mkHandleFromHANDLE hwnd Stream ident mode (Just enc)
#endif
System/Process/CommunicationHandle.hs 0 → 100644
View file @ 98101f82
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
module System.Process.CommunicationHandle
( -- * 'CommunicationHandle': a 'Handle' that can be serialised,
-- enabling inter-process communication.
CommunicationHandle
-- NB: opaque, as the representation depends on the operating system
, openCommunicationHandleRead
, openCommunicationHandleWrite
, closeCommunicationHandle
-- * Creating 'CommunicationHandle's to communicate with
-- a child process
, createWeReadTheyWritePipe
, createTheyReadWeWritePipe
-- * High-level API
, readCreateProcessWithExitCodeCommunicationHandle
)
where
import GHC.IO.Handle (Handle)
import System.Process.CommunicationHandle.Internal
import System.Process.Internals
( CreateProcess(..), ignoreSigPipe, withForkWait )
import System.Process
( withCreateProcess, waitForProcess )
import GHC.IO (evaluate)
import GHC.IO.Handle (hClose)
import System.Exit (ExitCode)
import Control.DeepSeq (NFData, rnf)
--------------------------------------------------------------------------------
-- Communication handles.
-- | Turn the 'CommunicationHandle' into a 'Handle' that can be read from
-- in the current process.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- @since 1.6.20.0
openCommunicationHandleRead :: CommunicationHandle -> IO Handle
openCommunicationHandleRead = useCommunicationHandle True
-- | Turn the 'CommunicationHandle' into a 'Handle' that can be written to
-- in the current process.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- @since 1.6.20.0
openCommunicationHandleWrite :: CommunicationHandle -> IO Handle
openCommunicationHandleWrite = useCommunicationHandle False
--------------------------------------------------------------------------------
-- Creating pipes.
-- | Create a pipe @(weRead,theyWrite)@ that the current process can read from,
-- and whose write end can be passed to a child process in order to receive data from it.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createWeReadTheyWritePipe
:: IO (Handle, CommunicationHandle)
createWeReadTheyWritePipe =
createCommunicationPipe id False
-- safe choice: passAsyncHandleToChild = False, in case the child cannot
-- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
-- expert users can invoke createCommunicationPipe from
-- System.Process.CommunicationHandle.Internals if they are sure that the
-- child process they will communicate with supports async I/O on Windows
-- | Create a pipe @(theyRead,weWrite)@ that the current process can write to,
-- and whose read end can be passed to a child process in order to send data to it.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
--
-- See 'CommunicationHandle'.
--
-- @since 1.6.20.0
createTheyReadWeWritePipe
:: IO (CommunicationHandle, Handle)
createTheyReadWeWritePipe =
sw <$> createCommunicationPipe sw False
-- safe choice: passAsyncHandleToChild = False, in case the child cannot
-- deal with async I/O (see e.g. https://gitlab.haskell.org/ghc/ghc/-/issues/21610#note_431632)
-- expert users can invoke createCommunicationPipe from
-- System.Process.CommunicationHandle.Internals if they are sure that the
-- child process they will communicate with supports async I/O on Windows
where
sw (a,b) = (b,a)
--------------------------------------------------------------------------------
-- | A version of 'readCreateProcessWithExitCode' that communicates with the
-- child process through a pair of 'CommunicationHandle's.
--
-- Example usage:
--
-- > readCreateProcessWithExitCodeCommunicationHandle
-- > (\(chTheyRead, chTheyWrite) -> proc "child-exe" [show chTheyRead, show chTheyWrite])
-- > (\ hWeRead -> hGetContents hWeRead)
-- > (\ hWeWrite -> hPut hWeWrite "xyz")
--
-- where @child-exe@ is a separate executable that is implemented as:
--
-- > main = do
-- > [chRead, chWrite] <- getArgs
-- > hRead <- openCommunicationHandleRead $ read chRead
-- > hWrite <- openCommunicationHandleWrite $ read chWrite
-- > input <- hGetContents hRead
-- > hPut hWrite $ someFn input
-- > hClose hWrite
--
-- @since 1.6.20.0
readCreateProcessWithExitCodeCommunicationHandle
:: NFData a
=> ((CommunicationHandle, CommunicationHandle) -> CreateProcess)
-- ^ Process to spawn, given a @(read, write)@ pair of
-- 'CommunicationHandle's that are inherited by the spawned process
-> (Handle -> IO a)
-- ^ read action
-> (Handle -> IO ())
-- ^ write action
-> IO (ExitCode, a)
readCreateProcessWithExitCodeCommunicationHandle mkProg readAction writeAction = do
(chTheyRead, hWeWrite ) <- createTheyReadWeWritePipe
(hWeRead , chTheyWrite) <- createWeReadTheyWritePipe
let cp = mkProg (chTheyRead, chTheyWrite)
-- The following implementation parallels 'readCreateProcess'
withCreateProcess cp $ \ _ _ _ ph -> do
-- Close the parent's references to the 'CommunicationHandle's after they
-- have been inherited by the child (we don't want to keep pipe ends open).
closeCommunicationHandle chTheyWrite
closeCommunicationHandle chTheyRead
-- Fork off a thread that waits on the output.
output <- readAction hWeRead
withForkWait (evaluate $ rnf output) $ \ waitOut -> do
ignoreSigPipe $ writeAction hWeWrite
ignoreSigPipe $ hClose hWeWrite
waitOut
hClose hWeRead
ex <- waitForProcess ph
return (ex, output)
System/Process/CommunicationHandle/Internal.hsc 0 → 100644
View file @ 98101f82
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
module System.Process.CommunicationHandle.Internal
( -- * 'CommunicationHandle': a 'Handle' that can be serialised,
-- enabling inter-process communication.
CommunicationHandle(..)
, closeCommunicationHandle
-- ** Internal functions
, useCommunicationHandle
, createCommunicationPipe
)
where
import Control.Arrow ( first )
import GHC.IO.Handle (Handle, hClose)
#if defined(mingw32_HOST_OS)
import Foreign.C (CInt(..), throwErrnoIf_)
import Foreign.Marshal (alloca)
import Foreign.Ptr (ptrToWordPtr, wordPtrToPtr)
import Foreign.Storable (Storable(peek))
import GHC.IO.Handle.FD (fdToHandle)
import GHC.IO.IOMode (IOMode(ReadMode, WriteMode))
import System.Process.Windows (HANDLE, mkNamedPipe)
## if defined(__IO_MANAGER_WINIO__)
import Control.Exception (catch, throwIO)
import GHC.IO (onException)
import GHC.IO.Device as IODevice (close, devType)
import GHC.IO.Encoding (getLocaleEncoding)
import GHC.IO.Exception (IOException(..), IOErrorType(InvalidArgument))
import GHC.IO.IOMode (IOMode(ReadWriteMode))
import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
import GHC.IO.SubSystem ((<!>))
import GHC.IO.Windows.Handle (Io, NativeHandle, fromHANDLE)
import GHC.Event.Windows (associateHandle')
import System.Process.Common (rawHANDLEToHandle)
## else
import System.Process.Common (rawFdToHandle)
## endif
#include <fcntl.h> /* for _O_BINARY */
#else
import GHC.IO.FD
( mkFD, setNonBlockingMode )
import GHC.IO.Handle
( noNewlineTranslation )
#if MIN_VERSION_base(4,16,0)
import GHC.IO.Handle.Internals
( mkFileHandleNoFinalizer )
#else
import GHC.IO.IOMode
( IOMode(..) )
import GHC.IO.Handle.Types
( HandleType(..) )
import GHC.IO.Handle.Internals
( mkHandle )
#endif
import System.Posix
( Fd(..)
, FdOption(..), setFdOption
)
import System.Posix.Internals
( fdGetMode )
import System.Process.Internals
( createPipeFd )
#endif
--------------------------------------------------------------------------------
-- Communication handles.
-- | A 'CommunicationHandle' is an abstraction over operating-system specific
-- internal representation of a 'Handle', which can be communicated through a
-- command-line interface.
--
-- In a typical use case, the parent process creates a pipe, using e.g.
-- 'createWeReadTheyWritePipe' or 'createTheyReadWeWritePipe'.
--
-- - One end of the pipe is a 'Handle', which can be read from/written to by
-- the parent process.
-- - The other end is a 'CommunicationHandle', which can be inherited by a
-- child process. A reference to the handle can be serialised (using
-- the 'Show' instance), and passed to the child process.
-- It is recommended to close the parent's reference to the 'CommunicationHandle'
-- using 'closeCommunicationHandle' after it has been inherited by the child
-- process.
-- - The child process can deserialise the 'CommunicationHandle' (using
-- the 'Read' instance), and then use 'openCommunicationHandleWrite' or
-- 'openCommunicationHandleRead' in order to retrieve a 'Handle' which it
-- can write to/read from.
--
-- 'readCreateProcessWithExitCodeCommunicationHandle' provides a high-level API
-- to this functionality. See there for example code.
--
-- @since 1.6.20.0
newtype CommunicationHandle =
CommunicationHandle
##if defined(mingw32_HOST_OS)
HANDLE
##else
Fd
##endif
deriving ( Eq, Ord )
#if defined(mingw32_HOST_OS)
type Fd = CInt
#endif
-- @since 1.6.20.0
instance Show CommunicationHandle where
showsPrec p (CommunicationHandle h) =
showsPrec p
##if defined(mingw32_HOST_OS)
$ ptrToWordPtr
##endif
h
-- @since 1.6.20.0
instance Read CommunicationHandle where
readsPrec p str =
fmap
( first $ CommunicationHandle
##if defined(mingw32_HOST_OS)
. wordPtrToPtr
##endif
) $
readsPrec p str
-- | Internal function used to define 'openCommunicationHandleRead' and
-- openCommunicationHandleWrite.
useCommunicationHandle :: Bool -> CommunicationHandle -> IO Handle
useCommunicationHandle _wantToRead (CommunicationHandle ch) = do
##if defined(__IO_MANAGER_WINIO__)
return ()
<!> associateHandleWithFallback _wantToRead ch
##endif
getGhcHandle ch
-- | Close a 'CommunicationHandle'.
--
-- Use this to close the 'CommunicationHandle' in the parent process after
-- the 'CommunicationHandle' has been inherited by the child process.
--
-- @since 1.6.20.0
closeCommunicationHandle :: CommunicationHandle -> IO ()
closeCommunicationHandle (CommunicationHandle ch) =
hClose =<< getGhcHandle ch
##if defined(__IO_MANAGER_WINIO__)
-- Internal function used when associating a 'HANDLE' with the current process.
--
-- Explanation: with WinIO, a synchronous handle cannot be associated with the
-- current process, while an asynchronous one must be associated before being usable.
--
-- In a child process, we don't necessarily know which kind of handle we will receive,
-- so we try to associate it (in case it is an asynchronous handle). This might
-- fail (if the handle is synchronous), in which case we continue in synchronous
-- mode (without associating).
--
-- With the current API, inheritable handles in WinIO created with mkNamedPipe
-- are synchronous, but it's best to be safe in case the child receives an
-- asynchronous handle anyway.
associateHandleWithFallback :: Bool -> HANDLE -> IO ()
associateHandleWithFallback _wantToRead h =
associateHandle' h `catch` handler
where
handler :: IOError -> IO ()
handler ioErr@(IOError { ioe_handle = _mbErrHandle, ioe_type = errTy, ioe_errno = mbErrNo })
-- Catches the following error that occurs when attemping to associate
-- a HANDLE that does not have OVERLAPPING mode set:
--
-- associateHandleWithIOCP: invalid argument (The parameter is incorrect.)
| InvalidArgument <- errTy
, Just 22 <- mbErrNo
= return ()
| otherwise
= throwIO ioErr
##endif
-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
#if defined(mingw32_HOST_OS)
getGhcHandle :: HANDLE -> IO Handle
getGhcHandle =
getGhcHandlePOSIX
## if defined(__IO_MANAGER_WINIO__)
<!> getGhcHandleNative
## endif
getGhcHandlePOSIX :: HANDLE -> IO Handle
getGhcHandlePOSIX handle = openHANDLE handle >>= fdToHandle
openHANDLE :: HANDLE -> IO Fd
openHANDLE handle = _open_osfhandle handle (#const _O_BINARY)
foreign import ccall "io.h _open_osfhandle"
_open_osfhandle :: HANDLE -> CInt -> IO Fd
## if defined(__IO_MANAGER_WINIO__)
getGhcHandleNative :: HANDLE -> IO Handle
getGhcHandleNative hwnd =
do mb_codec <- fmap Just getLocaleEncoding
let iomode = ReadWriteMode
native_handle = fromHANDLE hwnd :: Io NativeHandle
hw_type <- IODevice.devType $ native_handle
mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec
`onException` IODevice.close native_handle
## endif
#else
getGhcHandle :: Fd -> IO Handle
getGhcHandle (Fd fdint) = do
iomode <- fdGetMode fdint
(fd0, _) <- mkFD fdint iomode Nothing False True
-- The following copies over 'mkHandleFromFDNoFinalizer'
fd <- setNonBlockingMode fd0 True
let fd_str = "<file descriptor: " ++ show fd ++ ">"
# if MIN_VERSION_base(4,16,0)
mkFileHandleNoFinalizer fd fd_str iomode Nothing noNewlineTranslation
# else
mkHandle fd fd_str (ioModeToHandleType iomode) True Nothing noNewlineTranslation
Nothing Nothing
ioModeToHandleType :: IOMode -> HandleType
ioModeToHandleType mode =
case mode of
ReadMode -> ReadHandle
WriteMode -> WriteHandle
ReadWriteMode -> ReadWriteHandle
AppendMode -> AppendHandle
# endif
#endif
--------------------------------------------------------------------------------
-- Creating pipes.
-- | Internal helper function used to define 'createWeReadTheyWritePipe'
-- and 'createTheyReadWeWritePipe' while reducing code duplication.
--
-- The returned 'Handle' does not have any finalizers attached to it;
-- use 'hClose' to close it.
createCommunicationPipe
:: ( forall a. (a, a) -> (a, a) )
-- ^ 'id' (we read, they write) or 'swap' (they read, we write)
-> Bool -- ^ whether to pass a handle supporting asynchronous I/O to the child process
-- (this flag only has an effect on Windows and when using WinIO)
-> IO (Handle, CommunicationHandle)
createCommunicationPipe swapIfTheyReadWeWrite _passAsyncHandleToChild = do
##if !defined(mingw32_HOST_OS)
-- NB: it's important to use 'createPipeFd' here.
--
-- Were we to instead use 'createPipe', we would create a Handle for both pipe
-- ends, including the end we pass to the child.
-- Such Handle would have a finalizer which closes the underlying file descriptor.
-- However, we will already close the FD after it is inherited by the child.
-- This could lead to the following scenario:
--
-- - the parent creates a new pipe, e.g. pipe2([7,8]),
-- - the parent spawns a child process, and lets FD 8 be inherited by the child,
-- - the parent closes FD 8,
-- - the parent opens FD 8 for some other purpose, e.g. for writing to a file,
-- - the finalizer for the Handle wrapping FD 8 runs, closing FD 8, even though
-- it is now in use for a completely different purpose.
(ourFd, theirFd) <- swapIfTheyReadWeWrite <$> createPipeFd
-- Don't allow the child process to inherit a parent file descriptor
-- (such inheritance happens by default on Unix).
setFdOption (Fd ourFd) CloseOnExec True
-- NB: we will be closing this handle manually, so don't use 'handleFromFd'
-- which attaches a finalizer that closes the FD. See the above comment
-- about 'createPipeFd'.
ourHandle <- getGhcHandle (Fd ourFd)
return (ourHandle, CommunicationHandle $ Fd theirFd)
##else
trueForWinIO <-
return False
## if defined (__IO_MANAGER_WINIO__)
<!> return True
## endif
-- On Windows, use mkNamedPipe to create the two pipe ends.
alloca $ \ pfdStdInput ->
alloca $ \ pfdStdOutput -> do
let (inheritRead, inheritWrite) = swapIfTheyReadWeWrite (False, True)
-- WinIO:
-- - make the parent pipe end overlapped,
-- - make the child end overlapped if requested,
-- Otherwise: make both pipe ends synchronous.
overlappedRead = trueForWinIO && ( _passAsyncHandleToChild || not inheritRead )
overlappedWrite = trueForWinIO && ( _passAsyncHandleToChild || not inheritWrite )
throwErrnoIf_ (==False) "mkNamedPipe" $
mkNamedPipe
pfdStdInput inheritRead overlappedRead
pfdStdOutput inheritWrite overlappedWrite
let ((ourPtr, ourMode), (theirPtr, _theirMode)) =
swapIfTheyReadWeWrite ((pfdStdInput, ReadMode), (pfdStdOutput, WriteMode))
ourHANDLE <- peek ourPtr
theirHANDLE <- peek theirPtr
-- With WinIO, we need to associate any handles we are going to use in
-- the current process before being able to use them.
return ()
## if defined (__IO_MANAGER_WINIO__)
<!> associateHandle' ourHANDLE
## endif
ourHandle <-
## if !defined (__IO_MANAGER_WINIO__)
( \ fd -> rawFdToHandle fd ourMode ) =<< openHANDLE ourHANDLE
## else
-- NB: it's OK to call the following function even when we're not
-- using WinIO at runtime, so we don't use <!>.
rawHANDLEToHandle ourHANDLE ourMode
## endif
return $ (ourHandle, CommunicationHandle theirHANDLE)
##endif
System/Process/Environment/OsString.hs 0 → 100644
View file @ 98101f82
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
-- | Miscellaneous information about the system environment, for 'OsString'.
--
-- @since 1.6.26.0
module System.Process.Environment.OsString (
getArgs,
getEnv,
getEnvironment,
) where
import Data.Coerce (coerce)
#if MIN_VERSION_filepath(1, 5, 0)
import "os-string" System.OsString.Internal.Types (OsString(OsString))
#else
import "filepath" System.OsString.Internal.Types (OsString(OsString))
#endif
#if defined(mingw32_HOST_OS)
import qualified System.Win32.WindowsString.Console as Platform
#else
import qualified System.Posix.Env.PosixString as Platform
#endif
-- | 'System.Environment.getArgs' for 'OsString'.
--
-- @since 1.6.26.0
getArgs :: IO [OsString]
getArgs = coerce Platform.getArgs
-- | 'System.Environment.getEnv' for 'OsString'.
--
-- @since 1.6.26.0
getEnv :: OsString -> IO (Maybe OsString)
getEnv = coerce Platform.getEnv
-- | 'System.Environment.getEnvironment' for 'OsString'.
--
-- @since 1.6.26.0
getEnvironment :: IO [(OsString, OsString)]
getEnvironment = coerce Platform.getEnvironment
System/Process/Internals.hs
View file @ 98101f82
......@@ -22,7 +22,7 @@
module System.Process.Internals (
ProcessHandle(..), ProcessHandle__(..),
PHANDLE, closePHANDLE, mkProcessHandle,
#ifdef WINDOWS
#if defined(mingw32_HOST_OS)
CGid(..),
#else
CGid,
......@@ -39,32 +39,42 @@ module System.Process.Internals (
endDelegateControlC,
stopDelegateControlC,
unwrapHandles,
#ifdef WINDOWS
#if defined(mingw32_HOST_OS)
terminateJob,
terminateJobUnsafe,
waitForJobCompletion,
timeout_Infinite,
#else
#if !defined(javascript_HOST_ARCH)
pPrPr_disableITimers, c_execvpe,
ignoreSignal, defaultSignal,
runInteractiveProcess_lock,
#endif
ignoreSignal, defaultSignal,
#endif
withFilePathException, withCEnvironment,
translate,
createPipe,
createPipeFd,
interruptProcessGroupOf,
withForkWait,
ignoreSigPipe,
) where
import Control.Concurrent
import Control.Exception (SomeException, mask, try, throwIO)
import qualified Control.Exception as C
import Foreign.C
import System.IO
import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
import GHC.IO.Handle.FD (fdToHandle)
import System.Posix.Internals (FD)
import System.Process.Common
#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
import System.Process.JavaScript
#elif defined(mingw32_HOST_OS)
import System.Process.Windows
#else
import System.Process.Posix
......@@ -85,7 +95,12 @@ import System.Process.Posix
--
-- @since 1.2.1.0
createProcess_
:: String -- ^ function name (for error messages)
:: String
-- ^ Function name (for error messages).
--
-- This can be any 'String', but will typically be the name of the caller.
-- E.g., 'spawnProcess' passes @"spawnProcess"@ here when calling
-- 'createProcess_'.
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ msg proc_ = unwrapHandles `fmap` createProcess_Internal msg proc_
......@@ -166,7 +181,6 @@ runGenProcess_
-> Maybe CLong -- ^ handler for SIGINT
-> Maybe CLong -- ^ handler for SIGQUIT
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-- 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
......@@ -177,6 +191,33 @@ runGenProcess_ fun c _ _ = createProcess_ fun c
-- | Create a pipe for interprocess communication and return a
-- @(readEnd, writeEnd)@ `Handle` pair.
--
-- * WinIO Support
--
-- When this function is used with WinIO enabled it's the caller's
-- responsibility to register the handles with the I/O manager.
-- If this is not done the operation will deadlock. Association can
-- be done as follows:
--
-- @
-- #if defined(__IO_MANAGER_WINIO__)
-- import GHC.IO.SubSystem ((`<!>`))
-- import GHC.IO.Handle.Windows (handleToHANDLE)
-- import GHC.Event.Windows (associateHandle')
-- #endif
--
-- ...
--
-- #if defined(__IO_MANAGER_WINIO__)
-- return () \<!> do
-- associateHandle' =\<\< handleToHANDLE readEnd
-- #endif
-- @
--
-- Only associate handles that you are in charge of read/writing to.
-- Do not associate handles passed to another process. It's the
-- process's responsibility to register the handle if it supports
-- async access.
--
-- @since 1.2.1.0
createPipe :: IO (Handle, Handle)
createPipe = createPipeInternal
......@@ -208,3 +249,29 @@ interruptProcessGroupOf
:: ProcessHandle -- ^ A process in the process group
-> IO ()
interruptProcessGroupOf = interruptProcessGroupOfInternal
-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
-- @since 1.6.20.0
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return
restore (body wait) `C.onException` killThread tid
-- | Handle any SIGPIPE errors in the given computation.
--
-- @since 1.6.20.0
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = C.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
\ No newline at end of file
System/Process/JavaScript.hs 0 → 100644
View file @ 98101f82
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-
Child process support for JavaScript running on the node.js platform.
Other platforms such as browsers will accept the JavaScript code, but all
operations will result in unsupported operation exceptions.
-}
#include "HsProcessConfig.h"
module System.Process.JavaScript
( mkProcessHandle
, translateInternal
, createProcess_Internal
, withCEnvironment
, closePHANDLE
, startDelegateControlC
, endDelegateControlC
, stopDelegateControlC
, isDefaultSignal
, ignoreSignal
, defaultSignal
, createPipeInternal
, createPipeInternalFd
, interruptProcessGroupOfInternal
, getProcessId
, getCurrentProcessId
) where
import Control.Concurrent.MVar
import Control.Exception (throwIO)
import Data.Char (isAlphaNum)
import System.Exit
import System.IO
import System.IO.Error
import qualified System.Posix.Internals as Posix
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import GHC.IO.Handle.FD (mkHandleFromFD)
import GHC.IO.Device (IODeviceType(..))
import GHC.IO.Encoding (getLocaleEncoding)
import GHC.IO.Exception
import qualified GHC.IO.FD as FD
import GHC.JS.Prim
import System.Process.Common hiding (mb_delegate_ctlc, mbPipe)
mkProcessHandle :: JSVal -> Bool -> IO ProcessHandle
mkProcessHandle p mb_delegate_ctlc = do
m <- newMVar (OpenHandle p)
ml <- newMVar ()
return (ProcessHandle m mb_delegate_ctlc ml)
closePHANDLE :: JSVal -> IO ()
closePHANDLE _ = return ()
getProcessId :: PHANDLE -> IO Int
getProcessId ph =
throwErrnoIfMinus1 "getProcessId" (js_getProcessId ph)
getCurrentProcessId :: IO Int
getCurrentProcessId =
throwErrnoIfMinus1 "getCurrentProcessId" js_getCurrentProcessId
startDelegateControlC :: IO ()
startDelegateControlC =
throwErrnoIfMinus1_ "startDelegateControlC" js_startDelegateControlC
stopDelegateControlC :: IO ()
stopDelegateControlC =
throwErrnoIfMinus1_ "stopDelegateControlC" js_stopDelegateControlC
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC (ExitFailure (-2)) = throwIO UserInterrupt -- SIGINT
endDelegateControlC _ = pure ()
ignoreSignal, defaultSignal :: CLong
ignoreSignal = CONST_SIG_IGN
defaultSignal = CONST_SIG_DFL
isDefaultSignal :: CLong -> Bool
isDefaultSignal = (== defaultSignal)
interruptProcessGroupOfInternal
:: ProcessHandle -- ^ A process in the process group
-> IO ()
interruptProcessGroupOfInternal ph =
withProcessHandle ph $ \p_ -> do
case p_ of
OpenExtHandle{} -> return ()
ClosedHandle _ -> return ()
OpenHandle h ->
throwErrnoIfMinus1_ "interruptProcessGroupOfInternal"
(js_interruptProcessGroupOf h)
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` "-_.,/"
-- node.js does not appear to have any built-in facilities
-- for creating pipes, so we leave this as an unsupported operation
-- for now
createPipeInternal :: IO (Handle, Handle)
createPipeInternal = ioError
(ioeSetLocation unsupportedOperation "createPipeInternal")
createPipeInternalFd :: IO (Posix.FD, Posix.FD)
createPipeInternalFd = ioError
(ioeSetLocation unsupportedOperation "createPipeInternalFd")
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)
commandToProcess :: CmdSpec -> IO (FilePath, [String])
commandToProcess cmd =
case cmd of
ShellCommand xs -> c2p (toJSString xs) jsNull
RawCommand c args -> c2p (toJSString c) =<< toJSStrings args
where
c2p c as = do
r <- throwErrnoIfJSNull "commandToProcess" (js_commandToProcess c as)
fromJSStrings r >>= \case
(x:xs) -> pure (x,xs)
_ -> error "commandToProcess: empty list"
-- -----------------------------------------------------------------------------
-- JavaScript nodejs runProcess with signal handling in the child
createProcess_Internal
:: String
-- ^ Function name (for error messages).
--
-- This can be any 'String', but will typically be the name of the caller.
-- E.g., 'spawnProcess' passes @"spawnProcess"@ here when calling
-- 'createProcess_'.
-> CreateProcess
-> IO ProcRetHandles
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,
new_session = mb_new_session,
child_user = mb_child_user,
child_group = mb_child_group }
= do
(cmd, args) <- commandToProcess cmdsp
withFilePathException cmd $ do
fdin <- mbFd fun fd_stdin mb_stdin
fdout <- mbFd fun fd_stdout mb_stdout
fderr <- mbFd fun fd_stderr mb_stderr
env' <- maybe (pure jsNull)
(toJSStrings . concatMap (\(x,y) -> [x,y]))
mb_env
let cwd' = maybe jsNull toJSString mb_cwd
let c1 = toJSString cmd
c2 <- case args of
[] -> return jsNull
_ -> toJSStrings args
r <- throwErrnoIfJSNull fun $
js_runInteractiveProcess c1
c2
cwd'
env'
fdin
fdout
fderr
mb_close_fds
mb_create_group
mb_delegate_ctlc
mb_new_session
(maybe (-1) fromIntegral mb_child_group)
(maybe (-1) fromIntegral mb_child_user)
fdin_r:fdout_r:fderr_r:_ <-
map (stdFD . fromIntegral) <$> (fromJSInts =<< getProp r "fds")
hndStdInput <- mbPipe mb_stdin fdin_r WriteMode
hndStdOutput <- mbPipe mb_stdout fdout_r ReadMode
hndStdError <- mbPipe mb_stderr fderr_r ReadMode
ph <- mkProcessHandle r mb_delegate_ctlc
return $ ProcRetHandles { hStdInput = hndStdInput
, hStdOutput = hndStdOutput
, hStdError = hndStdError
, procHandle = ph
}
mbPipe :: StdStream -> FD.FD -> IOMode -> IO (Maybe Handle)
mbPipe CreatePipe fd mode = do
enc <- getLocaleEncoding
fmap Just (mkHandleFromFD fd
Stream
("fd: " ++ show fd)
mode
False {-is_socket-}
(Just enc))
mbPipe _ _ _ = do
return Nothing
stdFD :: CInt -> FD.FD
stdFD fd = FD.FD { FD.fdFD = fd
, FD.fdIsNonBlocking = 0
}
-- -----------------------------------------------------------------------------
-- Some helpers for dealing with JavaScript values
-- JavaScript value type synonyms, for readability
type JSArray = JSVal
type JSString = JSVal
fromJSStrings :: JSVal -> IO [String]
fromJSStrings x = fmap (map fromJSString) (fromJSArray x)
fromJSInts :: JSVal -> IO [Int]
fromJSInts x = map fromJSInt <$> fromJSArray x
toJSStrings :: [String] -> IO JSVal
toJSStrings xs = toJSArray (map toJSString xs)
throwErrnoIfJSNull :: String -> IO JSVal -> IO JSVal
throwErrnoIfJSNull msg m = do
r <- m
if isNull r then throwErrno msg
else return r
-- -----------------------------------------------------------------------------
-- Foreign imports from process.js
-- run an interactive process. Note that this foreign import is asynchronous
-- (interruptible) since it waits until the process has spawned (or an error
-- has occurred.
--
-- this should only be a short time, so it should be safe to call this from
-- an uninterruptible mask.
foreign import javascript interruptible "h$process_runInteractiveProcess"
js_runInteractiveProcess
:: JSString -- ^ command or program
-> JSArray -- ^ arguments, null if it's a raw command
-> JSString -- ^ working dir, null for current
-> JSArray -- ^ environment, null for existing
-> CInt -- ^ stdin fd
-> CInt -- ^ stdout fd
-> CInt -- ^ stderr fd
-> Bool -- ^ close file descriptors in child (currently unsupported)
-> Bool -- ^ create a new process group
-> Bool -- ^ delegate ctrl-c
-> Bool -- ^ create a new session
-> Int -- ^ set child GID (-1 for unchanged)
-> Int -- ^ set child UID (-1 for unchanged)
-> IO JSVal -- ^ process handle (null if an error occurred)
foreign import javascript safe "h$process_commandToProcess"
js_commandToProcess
:: JSString
-> JSArray
-> IO JSArray
foreign import javascript unsafe "h$process_interruptProcessGroupOf"
js_interruptProcessGroupOf
:: PHANDLE
-> IO Int
foreign import javascript unsafe "h$process_startDelegateControlC"
js_startDelegateControlC
:: IO Int
foreign import javascript unsafe "h$process_stopDelegateControlC"
js_stopDelegateControlC
:: IO Int
foreign import javascript unsafe "h$process_getCurrentProcessId"
js_getCurrentProcessId
:: IO Int
foreign import javascript unsafe "h$process_getProcessId"
js_getProcessId
:: PHANDLE
-> IO Int
System/Process/Posix.hs
View file @ 98101f82
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
#include <ghcplatform.h>
module System.Process.Posix
( mkProcessHandle
, translateInternal
......@@ -43,6 +46,10 @@ import System.Posix.Process (getProcessGroupIDOf)
import System.Process.Common hiding (mb_delegate_ctlc)
#if defined(wasm32_HOST_ARCH)
import System.IO.Error
#endif
#include "HsProcessConfig.h"
#include "processFlags.h"
......@@ -129,7 +136,9 @@ createProcess_Internal fun
maybeWith withFilePath mb_cwd $ \pWorkDir ->
maybeWith with mb_child_group $ \pChildGroup ->
maybeWith with mb_child_user $ \pChildUser ->
withMany withFilePath (cmd:args) $ \cstrs ->
withFilePath cmd $ \cmdstr ->
withMany withCString args $ \argstrs -> do
let cstrs = cmdstr : argstrs
withArray0 nullPtr cstrs $ \pargs -> do
fdin <- mbFd fun fd_stdin mb_stdin
......@@ -139,18 +148,20 @@ createProcess_Internal fun
when mb_delegate_ctlc
startDelegateControlC
let flags = (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)
.|.(if mb_delegate_ctlc then RESET_INT_QUIT_HANDLERS else 0)
-- See the comment on runInteractiveProcess_lock
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))
flags
pFailedDoing
when (proc_handle == -1) $ do
......@@ -260,6 +271,27 @@ endDelegateControlC exitCode = do
where
sig = fromIntegral (-n)
#if defined(wasm32_HOST_ARCH)
c_runInteractiveProcess
:: Ptr CString
-> CString
-> Ptr CString
-> FD
-> FD
-> FD
-> Ptr FD
-> Ptr FD
-> Ptr FD
-> Ptr CGid
-> Ptr CUid
-> CInt -- flags
-> Ptr CString
-> IO PHANDLE
c_runInteractiveProcess _ _ _ _ _ _ _ _ _ _ _ _ _ = ioError (ioeSetLocation unsupportedOperation "runInteractiveProcess")
#else
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
:: Ptr CString
......@@ -273,11 +305,12 @@ foreign import ccall unsafe "runInteractiveProcess"
-> Ptr FD
-> Ptr CGid
-> Ptr CUid
-> CInt -- reset child's SIGINT & SIGQUIT handlers
-> CInt -- flags
-> Ptr CString
-> IO PHANDLE
#endif
ignoreSignal, defaultSignal :: CLong
ignoreSignal = CONST_SIG_IGN
defaultSignal = CONST_SIG_DFL
......
System/Process/Windows.hsc
View file @ 98101f82
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InterruptibleFFI #-}
module System.Process.Windows
( mkProcessHandle
......@@ -17,12 +18,17 @@ module System.Process.Windows
, terminateJobUnsafe
, waitForJobCompletion
, timeout_Infinite
, HANDLE
, mkNamedPipe
) where
import System.Process.Common
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Bits
import Data.Char (toLower)
import Data.List (dropWhileEnd)
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
......@@ -33,8 +39,8 @@ import System.Posix.Internals
import GHC.IO.Exception
##if defined(__IO_MANAGER_WINIO__)
import GHC.IO.SubSystem
import Graphics.Win32.Misc
import qualified GHC.Event.Windows as Mgr
import Graphics.Win32.Misc
##endif
import GHC.IO.Handle.FD
import GHC.IO.Handle.Types hiding (ClosedHandle)
......@@ -54,7 +60,7 @@ import System.Win32.Process (getProcessId)
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
##elif defined(x86_64_HOST_ARCH)
##elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)
## define WINDOWS_CCONV ccall
##else
## error Unknown mingw32 arch
......@@ -65,14 +71,14 @@ 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 -> PHANDLE -> IO ProcessHandle
mkProcessHandle h job = do
mkProcessHandle :: PHANDLE -> Bool -> PHANDLE -> IO ProcessHandle
mkProcessHandle h ignore_signals job = do
m <- if job == nullPtr
then newMVar (OpenHandle h)
else newMVar (OpenExtHandle h job)
_ <- mkWeakMVar m (processHandleFinaliser m)
l <- newMVar ()
return (ProcessHandle m False l)
return (ProcessHandle m ignore_signals l)
processHandleFinaliser :: MVar ProcessHandle__ -> IO ()
processHandleFinaliser m =
......@@ -114,7 +120,6 @@ createProcess_Internal_mio fun def@CreateProcess{
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,
......@@ -166,7 +171,7 @@ createProcess_Internal_wrapper _fun CreateProcess{
cmdspec = cmdsp,
cwd = mb_cwd,
env = mb_env,
delegate_ctlc = _ignored }
delegate_ctlc = ignore_signals }
action
= do
let lenPtr = sizeOf (undefined :: WordPtr)
......@@ -183,8 +188,15 @@ createProcess_Internal_wrapper _fun CreateProcess{
(proc_handle, hndStdInput, hndStdOutput, hndStdError)
<- action pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline
-- If we have successfully created the process then check if we have to
-- detach from the console. I'm not sure why the posix version changes
-- the state right before creating the child process, but doing so here
-- means the first child also inherits this
when ignore_signals $
startDelegateControlC
phJob <- peek hJob
ph <- mkProcessHandle proc_handle phJob
ph <- mkProcessHandle proc_handle ignore_signals phJob
return ProcRetHandles { hStdInput = hndStdInput
, hStdOutput = hndStdOutput
, hStdError = hndStdError
......@@ -203,7 +215,6 @@ createProcess_Internal_winio fun def@CreateProcess{
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,
......@@ -260,18 +271,71 @@ createProcess_Internal_winio fun def@CreateProcess{
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>
-- ----------------------------------------------------------------------------
-- Delegated control-C handling on Windows
-- See https://learn.microsoft.com/en-us/windows/console/setconsolectrlhandler
--
-- 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 CTRL_C_EVENT/CTRL_BREAK_EVENT Windows
-- events while we're running such programs.
--
-- 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.
--
-- To do this we have to use SetConsoleCtrlHandler which masks the events for
-- the current process and any child it creates from that point.
--
-- In this case we can't use FreeConsole/AttachConsole since those destroy
-- the signal handler stack for the application when called. This means we'd
-- have to recreate them and process doesn't know what's there.
{-# NOINLINE runInteractiveProcess_delegate_ctlc #-}
runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int))
runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing
startDelegateControlC :: IO ()
startDelegateControlC = return ()
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.
_ <- c_setConsoleCtrlHandler nullPtr True
return (Just 1)
Just count -> do
-- If we're already doing it, just increment the count
let !count' = count + 1
return (Just count')
stopDelegateControlC :: IO ()
stopDelegateControlC =
modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do
case delegating of
Just 1 -> do
-- Last process, so restore the old signal handlers
_ <- c_setConsoleCtrlHandler nullPtr False
return Nothing
Just count -> do
-- Not the last, just decrement the count
let !count' = count - 1
return (Just count')
Nothing -> return Nothing -- should be impossible
endDelegateControlC :: ExitCode -> IO ()
endDelegateControlC _ = return ()
-- I don't think there's a standard exit code for program interruptions
-- on Windows, so I'll just ignore it for now.
endDelegateControlC _ = stopDelegateControlC
stopDelegateControlC :: IO ()
stopDelegateControlC = return ()
-- End no-op functions
......@@ -308,6 +372,12 @@ foreign import WINDOWS_CCONV unsafe "TerminateJobObject"
-> CUInt
-> IO Bool
foreign import WINDOWS_CCONV unsafe "SetConsoleCtrlHandler"
c_setConsoleCtrlHandler
:: Ptr ()
-> Bool
-> IO Bool
foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
c_waitForJobCompletion
:: PHANDLE
......@@ -359,8 +429,27 @@ commandToProcess (ShellCommand string) = do
-- which partly works. There seem to be some quoting issues, but
-- I don't have the energy to find+fix them right now (ToDo). --SDM
-- (later) Now I don't know what the above comment means. sigh.
commandToProcess (RawCommand cmd args) = do
return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args)
commandToProcess (RawCommand cmd args)
| map toLower (takeWinExtension cmd) `elem` [".bat", ".cmd"]
= return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateCmdExeArg) args)
| otherwise
= return (cmd, translateInternal cmd ++ concatMap ((' ':) . translateInternal) args)
-- TODO: filepath should also be updated with 'takeWinExtension'. Perhaps
-- some day we can remove this logic from `process` but there is no hurry.
-- | Get the extension of a Windows file, removing any trailing spaces or dots
-- since they are ignored.
--
-- See: <https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/file-folder-name-whitespace-characters>
--
-- >>> takeWinExtension "test.bat."
-- ".bat"
--
-- >>> takeWinExtension "test.bat ."
-- ".bat"
takeWinExtension :: FilePath -> String
takeWinExtension = takeExtension . dropWhileEnd (`elem` [' ', '.'])
-- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as
-- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation).
......@@ -401,6 +490,31 @@ findCommandInterpreter = do
"findCommandInterpreter" Nothing Nothing)
Just cmd -> return cmd
-- | Alternative regime used to escape arguments destined for scripts
-- interpreted by @cmd.exe@, (e.g. @.bat@ and @.cmd@ files).
--
-- This respects the Windows command interpreter's quoting rules:
--
-- * the entire argument should be surrounded in quotes
-- * the backslash symbol is used to escape quotes and backslashes
-- * the carat symbol is used to escape other special characters with
-- significance to the interpreter
--
-- It is particularly important that we perform this quoting as
-- unvalidated unquoted command-line arguments can be used to achieve
-- arbitrary user code execution in when passed to a vulnerable batch
-- script.
--
translateCmdExeArg :: String -> String
translateCmdExeArg xs = "^\"" ++ snd (foldr escape (True,"^\"") xs)
where escape '"' (_, str) = (True, '\\' : '"' : str)
escape '\\' (True, str) = (True, '\\' : '\\' : str)
escape '\\' (False, str) = (False, '\\' : str)
escape '%' (_, str) = (False, "%%cd:~,%" ++ str)
escape c (_, str)
| c `elem` "^<>|&()" = (False, '^' : c : str)
| otherwise = (False, c : str)
translateInternal :: String -> String
translateInternal xs = '"' : snd (foldr escape (True,"\"") xs)
where escape '"' (_, str) = (True, '\\' : '"' : str)
......@@ -448,17 +562,17 @@ createPipeInternalHANDLE :: IO (Handle, Handle)
createPipeInternalHANDLE =
alloca $ \ pfdStdInput ->
alloca $ \ pfdStdOutput -> do
throwErrnoIf_ (==False) "c_mkNamedPipe" $
c_mkNamedPipe pfdStdInput True pfdStdOutput True
Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput WriteMode
Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput ReadMode
throwErrnoIf_ (==False) "mkNamedPipe" $
mkNamedPipe pfdStdInput True False pfdStdOutput True False
Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput ReadMode
Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput WriteMode
return (hndStdInput, hndStdOutput)
foreign import ccall "mkNamedPipe" c_mkNamedPipe ::
Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool
##endif
foreign import ccall "mkNamedPipe" mkNamedPipe ::
Ptr HANDLE -> Bool -> Bool -> Ptr HANDLE -> Bool -> Bool -> IO Bool
close' :: CInt -> IO ()
close' = throwErrnoIfMinus1_ "_close" . c__close
......
aclocal.m4
View file @ 98101f82
......@@ -8,7 +8,7 @@
# is supported in autoconf versions 2.50 up to the actual 2.57, so there is
# little risk.
AC_DEFUN([FP_COMPUTE_INT],
[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl
[AC_COMPUTE_INT([$2],[$1],[$3],[$4])[]dnl
])# FP_COMPUTE_INT
......@@ -31,8 +31,7 @@ AS_VAR_POPDEF([fp_Cache])[]dnl
# ---------------------------------------
# autoheader helper for FP_CHECK_CONSTS
m4_define([FP_CHECK_CONSTS_TEMPLATE],
[AC_FOREACH([fp_Const], [$1],
[AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),
[m4_foreach_w([fp_Const],[$1],[AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),
[The value of ]fp_Const[.])])[]dnl
])# FP_CHECK_CONSTS_TEMPLATE
......
appveyor.yml deleted 100644 → 0
View file @ f295998c
cache:
- "c:\\sr" # stack root, short paths == less problems
build: off
before_test:
# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found
- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%
- curl -ostack.zip -L --insecure http://www.stackage.org/stack/windows-x86_64
- 7z x stack.zip stack.exe
clone_folder: "c:\\process"
environment:
global:
STACK_ROOT: "c:\\sr"
matrix:
- ARGS: "--resolver lts-6"
- ARGS: "--resolver lts-7"
- ARGS: "--resolver lts-9"
- ARGS: "--resolver lts-11"
- ARGS: "--resolver lts-12"
- ARGS: "--resolver lts-13"
- ARGS: "--resolver nightly"
- ARGS: "--stack-yaml stack-new-win32.yaml"
test_script:
# Generate the configure script. This took way too long to figure out
# correctly.
- c:\msys64\usr\bin\bash -lc "cd /c/process && autoreconf -i"
# The ugly echo "" hack is to avoid complaints about 0 being an invalid file
# descriptor
- echo "" | stack %ARGS% --no-terminal test --pedantic
cabal.project 0 → 100644
View file @ 98101f82
packages: ., test
cbits/posix/common.h 0 → 100644
View file @ 98101f82
#pragma once
#include "runProcess.h"
enum std_handle_behavior {
// Close the handle
STD_HANDLE_CLOSE,
// dup2 the specified fd to standard handle
STD_HANDLE_USE_FD,
// dup2 the appropriate end of the given pipe to the standard handle and
// close the other end.
STD_HANDLE_USE_PIPE
};
struct std_handle {
enum std_handle_behavior behavior;
union {
int use_fd;
struct {
int parent_end, child_end;
} use_pipe;
};
};
int get_max_fd(void);
// defined in find_executable.c
#if !defined(HAVE_EXECVPE)
char *find_executable(char *workingDirectory, char *filename);
#endif
// defined in fork_exec.c
#if defined(HAVE_FORK)
ProcHandle
do_spawn_fork (char *const args[],
char *workingDirectory, char **environment,
struct std_handle *stdInHdl,
struct std_handle *stdOutHdl,
struct std_handle *stdErrHdl,
gid_t *childGroup, uid_t *childUser,
int flags,
char **failed_doing);
#endif
// defined in posix_spawn.c
ProcHandle
do_spawn_posix (char *const args[],
char *workingDirectory, char **environment,
struct std_handle *stdInHdl,
struct std_handle *stdOutHdl,
struct std_handle *stdErrHdl,
gid_t *childGroup, uid_t *childUser,
int flags,
char **failed_doing);
cbits/posix/find_executable.c 0 → 100644
View file @ 98101f82
/* ----------------------------------------------------------------------------
* search path search logic
* (c) Ben Gamari 2021
*/
#include <string.h>
#include <unistd.h>
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
#include "common.h"
// the below is only necessary when we need to emulate execvpe.
#if !defined(HAVE_EXECVPE)
/* A quick check for whether the given path is absolute. */
static bool is_absolute(const char *path) {
return path[0] == '/';
}
static char *concat_paths(const char *path1, const char *path2) {
if (is_absolute(path2)) {
return strdup(path2);
} else {
int len = strlen(path1) + 1 + strlen(path2) + 1;
char *tmp = malloc(len);
int ret = snprintf(tmp, len, "%s/%s", path1, path2);
if (ret < 0) {
free(tmp);
return NULL;
}
return tmp;
}
}
/* Return true if the given file exists and is an executable, optionally
* relative to the given working directory.
*/
static bool is_executable(char *working_dir, const char *path) {
if (working_dir && !is_absolute(path)) {
char *tmp = concat_paths(working_dir, path);
bool ret = access(tmp, X_OK) == 0;
free(tmp);
return ret;
} else {
return access(path, X_OK) == 0;
}
}
/* Find an executable with the given filename in the given search path. The
* result must be freed by the caller. Returns NULL if a matching file is not
* found.
*/
static char *find_in_search_path(char *working_dir, char *search_path, const char *filename) {
const int filename_len = strlen(filename);
char *tokbuf;
char *path = strtok_r(search_path, ":", &tokbuf);
if (!working_dir)
working_dir = ".";
int workdir_len = strlen(working_dir);
while (path != NULL) {
// N.B. gcc 6.3.0, used by Debian 9, inexplicably warns that `path`
// may not be initialised with -Wall. Silence this warning. See #210.
#if defined(__GNUC__) && __GNUC__ == 6 && __GNUC_MINOR__ == 3
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
char *tmp;
if (is_absolute(path)) {
const int tmp_len = strlen(path) + 1 + filename_len + 1;
tmp = malloc(tmp_len);
snprintf(tmp, tmp_len, "%s/%s", path, filename);
} else {
const int tmp_len = workdir_len + 1 + strlen(path) + 1 + filename_len + 1;
tmp = malloc(tmp_len);
snprintf(tmp, tmp_len, "%s/%s/%s", working_dir, path, filename);
}
#if defined(__GNUC__) && __GNUC__ == 6 && __GNUC_MINOR__ == 3
#pragma GCC diagnostic pop
#endif
if (is_executable(working_dir, tmp)) {
return tmp;
} else {
free(tmp);
}
path = strtok_r(NULL, ":", &tokbuf);
}
return NULL;
}
/* Identify the executable search path. The result must be freed by the caller. */
static char *get_executable_search_path(void) {
char *search_path;
search_path = getenv("PATH");
if (search_path) {
search_path = strdup(search_path);
return search_path;
}
#if defined(HAVE_CONFSTR)
int len = confstr(_CS_PATH, NULL, 0);
search_path = malloc(len + 1)
if (search_path != NULL) {
search_path[0] = ':';
(void) confstr (_CS_PATH, search_path + 1, len);
return search_path;
}
#endif
return strdup(":");
}
/* Find the given executable in the executable search path relative to
* workingDirectory (or the current directory, if NULL).
* N.B. the caller is responsible for free()ing the result.
*/
char *find_executable(char *working_dir, char *filename) {
/* Drop trailing slash from working directory if necessary */
if (working_dir) {
int workdir_len = strlen(working_dir);
if (working_dir[workdir_len-1] == '/') {
working_dir[workdir_len-1] = '\0';
}
}
if (is_absolute(filename)) {
/* If it's an absolute path name, it's easy. */
return filename;
} else if (strchr(filename, '/')) {
/* If it's a relative path name, we must look for executables relative
* to the working directory. */
if (is_executable(working_dir, filename)) {
return filename;
}
}
/* Otherwise look through the search path... */
char *search_path = get_executable_search_path();
char *result = find_in_search_path(working_dir, search_path, filename);
free(search_path);
return result;
}
#endif
cbits/posix/fork_exec.c 0 → 100644
View file @ 98101f82
/* Ensure that execvpe and pipe2 are provided if possible */
#define _GNU_SOURCE 1
/* Ensure getpwuid_r(3) is available on Solaris. */
#if defined(__sun)
#define _POSIX_PTHREAD_SEMANTICS
#endif
#include "common.h"
#if defined(HAVE_FORK)
#include <sys/types.h>
#include <sys/wait.h>
#include <errno.h>
#include <unistd.h>
#include <stdlib.h>
#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
#include <pwd.h>
#include <grp.h>
#endif
#if defined(HAVE_FCNTL_H)
#include <fcntl.h>
#endif
#if defined(HAVE_SIGNAL_H)
#include <signal.h>
#endif
#include <Rts.h>
#if !defined(HAVE_WORKING_FORK)
#error Cannot find a working fork command
#endif
// Rts internal API, not exposed in a public header file:
extern void blockUserSignals(void);
extern void unblockUserSignals(void);
__attribute__((__noreturn__))
static void
child_failed(int pipe, const char *failed_doing) {
int err;
ssize_t unused __attribute__((unused));
err = errno;
// Having the child send the failed_doing pointer across the pipe is safe as
// we know that the child still has the same address space as the parent.
unused = write(pipe, &failed_doing, sizeof(failed_doing));
unused = write(pipe, &err, sizeof(err));
// As a fallback, exit
_exit(127);
}
static int
setup_std_handle_fork(int fd,
struct std_handle *b,
int pipe)
{
switch (b->behavior) {
case STD_HANDLE_CLOSE:
if (close(fd) == -1 && errno != EBADF) {
child_failed(pipe, "close");
}
return 0;
case STD_HANDLE_USE_FD:
// N.B. POSIX specifies that dup2(x,x) should be a no-op, but
// naturally Apple ignores this and rather fails in posix_spawn on Big
// Sur.
if (b->use_fd != fd) {
if (dup2(b->use_fd, fd) == -1) {
child_failed(pipe, "dup2");
}
}
return 0;
case STD_HANDLE_USE_PIPE:
if (b->use_pipe.child_end != fd) {
if (dup2(b->use_pipe.child_end, fd) == -1) {
child_failed(pipe, "dup2(child_end)");
}
if (close(b->use_pipe.child_end) == -1) {
child_failed(pipe, "close(child_end)");
}
}
if (close(b->use_pipe.parent_end) == -1) {
child_failed(pipe, "close(parent_end)");
}
return 0;
default:
// N.B. this should be unreachable but some compilers apparently can't
// see this.
child_failed(pipe, "setup_std_handle_fork(invalid behavior)");
}
}
/* This will `dup` the given fd such that it does not fall in the range of
* stdin/stdout/stderr, if necessary. The new handle will have O_CLOEXEC.
*
* This is necessary as we must ensure that the fork communications pipe does
* not inhabit fds 0 through 2 since we will need to manipulate these fds in
* setup_std_handle_fork while keeping the pipe available so that it can report
* errors. See #266.
*/
int unshadow_pipe_fd(int fd, char **failed_doing) {
if (fd > 2) {
return fd;
}
int new_fd = fcntl(fd, F_DUPFD_CLOEXEC, 3);
if (new_fd == -1) {
*failed_doing = "fcntl(F_DUP_FD)";
return -1;
}
close(fd);
return new_fd;
}
/* Try spawning with fork. */
ProcHandle
do_spawn_fork (char *const args[],
char *workingDirectory, char **environment,
struct std_handle *stdInHdl,
struct std_handle *stdOutHdl,
struct std_handle *stdErrHdl,
gid_t *childGroup, uid_t *childUser,
int flags,
char **failed_doing)
{
int forkCommunicationFds[2];
int r;
#if defined(HAVE_PIPE2)
r = pipe2(forkCommunicationFds, O_CLOEXEC);
#else
r = pipe(forkCommunicationFds);
#endif
if (r == -1) {
*failed_doing = "pipe";
return -1;
}
// Ensure that the pipe fds don't shadow stdin/stdout/stderr
forkCommunicationFds[0] = unshadow_pipe_fd(forkCommunicationFds[0], failed_doing);
if (forkCommunicationFds[0] == -1) {
return -1;
}
forkCommunicationFds[1] = unshadow_pipe_fd(forkCommunicationFds[1], failed_doing);
if (forkCommunicationFds[1] == -1) {
return -1;
}
// N.B. execvpe is not supposed on some platforms. In this case
// we emulate this using fork and exec. However, to safely do so
// we need to perform all allocations *prior* to forking. Consequently, we
// need to find_executable before forking.
#if !defined(HAVE_EXECVPE)
char *exec_path;
if (environment) {
exec_path = find_executable(workingDirectory, args[0]);
if (exec_path == NULL) {
errno = -ENOENT;
*failed_doing = "find_executable";
return -1;
}
}
#endif
// Block signals with Haskell handlers. The danger here is that
// with the threaded RTS, a signal arrives in the child process,
// the RTS writes the signal information into the pipe (which is
// shared between parent and child), and the parent behaves as if
// the signal had been raised.
blockUserSignals();
// See #4074. Sometimes fork() gets interrupted by the timer
// signal and keeps restarting indefinitely.
stopTimer();
int pid = fork();
switch(pid)
{
case -1:
unblockUserSignals();
startTimer();
close(forkCommunicationFds[0]);
close(forkCommunicationFds[1]);
*failed_doing = "fork";
return -1;
case 0:
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
child_failed(forkCommunicationFds[1], "setgid");
}
}
if (childUser) {
// Using setuid properly first requires that we initgroups.
// However, to do this we must know the username of the user we are
// switching to.
struct passwd pw;
struct passwd *res = NULL;
int buf_len = sysconf(_SC_GETPW_R_SIZE_MAX);
// TODO: Strictly speaking malloc is a no-no after fork() since it
// may try to take a lock
char *buf = malloc(buf_len);
gid_t suppl_gid = childGroup ? *childGroup : getgid();
if ( getpwuid_r(*childUser, &pw, buf, buf_len, &res) != 0) {
child_failed(forkCommunicationFds[1], "getpwuid");
}
if ( res == NULL ) {
child_failed(forkCommunicationFds[1], "getpwuid");
}
if ( initgroups(res->pw_name, suppl_gid) != 0) {
child_failed(forkCommunicationFds[1], "initgroups");
}
if ( setuid( *childUser) != 0) {
// ERROR
child_failed(forkCommunicationFds[1], "setuid");
}
}
unblockUserSignals();
if (workingDirectory) {
if (chdir (workingDirectory) < 0) {
child_failed(forkCommunicationFds[1], "chdir");
}
}
// Note [Ordering of handle closing]
// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Ordering matters here. If any of the FDs
// 0,1,2 were initially closed, then our pipes may have used
// these FDs. So when we dup2 the pipe FDs down to 0,1,2, we
// must do it in that order, otherwise we could overwrite an
// FD that we need later. See ticket #431.
setup_std_handle_fork(STDIN_FILENO, stdInHdl, forkCommunicationFds[1]);
setup_std_handle_fork(STDOUT_FILENO, stdOutHdl, forkCommunicationFds[1]);
setup_std_handle_fork(STDERR_FILENO, stdErrHdl, forkCommunicationFds[1]);
if ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0) {
int max_fd = get_max_fd();
// XXX Not the pipe
for (int i = 3; i < max_fd; i++) {
if (i != forkCommunicationFds[1]) {
close(i);
}
}
}
/* Reset the SIGINT/SIGQUIT signal handlers in the child, if requested
*/
if ((flags & RESET_INT_QUIT_HANDLERS) != 0) {
struct sigaction dfl;
(void)sigemptyset(&dfl.sa_mask);
dfl.sa_flags = 0;
dfl.sa_handler = SIG_DFL;
(void)sigaction(SIGINT, &dfl, NULL);
(void)sigaction(SIGQUIT, &dfl, NULL);
}
/* the child */
if (environment) {
#if defined(HAVE_EXECVPE)
// XXX Check result
execvpe(args[0], args, environment);
child_failed(forkCommunicationFds[1], "execvpe");
#else
// XXX Check result
execve(exec_path, args, environment);
child_failed(forkCommunicationFds[1], "execve");
#endif
} else {
// XXX Check result
execvp(args[0], args);
child_failed(forkCommunicationFds[1], "execvp");
}
default:
if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) {
setpgid(pid, pid);
}
close(forkCommunicationFds[1]);
fcntl(forkCommunicationFds[0], F_SETFD, FD_CLOEXEC);
break;
}
// If the child process had a problem, then it will tell us via the
// forkCommunicationFds pipe. First we try to read what the problem
// was. Note that if none of these conditionals match then we fall
// through and just return pid.
char *fail_reason;
r = read(forkCommunicationFds[0], &fail_reason, sizeof(fail_reason));
if (r == -1) {
*failed_doing = "read pipe";
pid = -1;
}
else if (r == sizeof(fail_reason)) {
*failed_doing = fail_reason;
// Now we try to get the errno from the child
int err;
r = read(forkCommunicationFds[0], &err, sizeof(err));
if (r == -1) {
*failed_doing = "read pipe";
} else if (r != sizeof(err)) {
*failed_doing = "read pipe bad length";
} else {
// If we succeed then we set errno. It'll be saved and
// restored again below. Note that in any other case we'll
// get the errno of whatever else went wrong instead.
errno = err;
}
// We forked the child, but the child had a problem and stopped so it's
// our responsibility to reap here as nobody else can.
waitpid(pid, NULL, 0);
// No need to close stdin, et al. here as runInteractiveProcess will
// handle this. See #306.
pid = -1;
}
else if (r != 0) {
*failed_doing = "read pipe bad length";
pid = -1;
}
close(forkCommunicationFds[0]);
unblockUserSignals();
startTimer();
return pid;
}
#endif // HAVE_FORK