Commit 14367828 authored by Steffen Michels's avatar Steffen Michels

System.Process.runProcess: pass all errors in child process before it is...

System.Process.runProcess: pass all errors in child process before it is replaced by 'execvp' to parent process (including error generated by 'execvp' itself
parent 46333bc2
......@@ -26,6 +26,9 @@ STDERR_FILENO :== 2
FIONREAD :== 0x541B
F_SETFD :== 2
O_CLOEXEC :== 02000000
//Posix API calls
errno :: !*w -> (!Int,!*w)
strerr :: !Int -> Pointer
......@@ -47,6 +50,8 @@ pipe :: !Pointer !*w -> (!Int, !*w)
dup2 :: !Int !Int !*w -> (!Int, !*w)
close :: !Int !*w -> (!Int, !*w)
ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w)
// variant requiring an argument as third parameter
fcntlArg :: !Int !Int !Int !*w -> (!Int, !*w)
read :: !Int !Pointer !Int !*w -> (!Int, !*w)
write :: !Int !{#Char} !Int !*w -> (!Int, !*w)
select_ :: !Int !Pointer !Pointer !Pointer !Pointer !*w -> (!Int, !*w)
......
......@@ -97,6 +97,11 @@ ioctl fd op ptr world = code {
ccall ioctl "IIp:I:A"
}
fcntlArg :: !Int !Int !Int !*w -> (!Int, !*w)
fcntlArg fd op arg world = code {
ccall fcntl "III:I:A"
}
read :: !Int !Pointer !Int !*w -> (!Int, !*w)
read fd buffer nBuffer world = code {
ccall read "IpI:I:A"
......
......@@ -12,3 +12,6 @@ import Data.Error
getLastOSError :: *w -> (MaybeOSError .a, *w)
getLastOSErrorCode :: *w -> (MaybeOSErrorCode .a, *w)
osErrorCodeToOSError :: OSErrorCode -> OSError
......@@ -7,13 +7,17 @@ getLastOSError :: *w -> (MaybeOSError .a, *w)
getLastOSError world
# (errno,world) = errno world
= (Error (errno, message errno),world)
where
message :: !Int -> String
message errno
# ptr = strerr errno
= derefString ptr
getLastOSErrorCode :: *w -> (MaybeOSErrorCode .a, *w)
getLastOSErrorCode world
# (errno,world) = errno world
= (Error errno, world)
osErrorCodeToOSError :: OSErrorCode -> OSError
osErrorCodeToOSError errno = (errno, message errno)
message :: !Int -> String
message errno
# ptr = strerr errno
= derefString ptr
......@@ -25,23 +25,10 @@ import System._Posix
:: ReadPipe = ReadPipe !Int
runProcess :: !FilePath ![String] !(Maybe String) !*World -> (MaybeOSError ProcessHandle, *World)
runProcess path args mCurrentDirectory world
//Fork
# (pid, world) = fork world
| pid == 0
//Chdir
# (res,world) = case mCurrentDirectory of
Just dir -> chdir (packString dir) world
Nothing -> (0, world)
| res <> 0 = getLastOSError world
//Exec
# (argv, world) = runProcessMakeArgv [path:args] world
# (res,world) = execvp (path +++ "\0") argv world
= (exit 1 world)
| pid > 0
= (Ok {ProcessHandle| pid = pid}, world)
| otherwise
= getLastOSError world
runProcess path args mCurrentDirectory world = runProcessFork
(runProcessChildProcessExec path args mCurrentDirectory)
runProcessParentProcessCheckError
world
runProcessIO :: !FilePath ![String] !(Maybe String) !*World -> (MaybeOSError (ProcessHandle, ProcessIO), *World)
runProcessIO path args mCurrentDirectory world
......@@ -57,43 +44,42 @@ runProcessIO path args mCurrentDirectory world
# (pipeStdErr, world) = openPipe world
| isError pipeStdErr = (liftError pipeStdErr, world)
# (pipeStdErrOut, pipeStdErrIn) = fromOk pipeStdErr
//Fork
# (pid, world) = fork world
| pid == 0
//Chdir
# (res,world) = case mCurrentDirectory of
Just dir -> chdir (packString dir) world
Nothing -> (0, world)
| res <> 0 = getLastOSError world
= runProcessFork (childProcess pipeStdInOut pipeStdInIn pipeStdOutOut pipeStdOutIn pipeStdErrOut pipeStdErrIn)
(parentProcess pipeStdInOut pipeStdInIn pipeStdOutOut pipeStdOutIn pipeStdErrOut pipeStdErrIn)
world
where
childProcess :: !Int !Int!Int !Int!Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
childProcess pipeStdInOut pipeStdInIn pipeStdOutOut pipeStdOutIn pipeStdErrOut pipeStdErrIn pipeExecErrorOut pipeExecErrorIn world
//redirect stdin/out/err to pipes
# (res, world) = dup2 pipeStdInOut STDIN_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdInIn world
| res == -1 = getLastOSError world
# (res, world) = dup2 pipeStdInOut STDIN_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdInIn world
| res == -1 = getLastOSError world
# (res, world) = dup2 pipeStdOutIn STDOUT_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdOutOut world
| res == -1 = getLastOSError world
# (res, world) = dup2 pipeStdOutIn STDOUT_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdOutOut world
| res == -1 = getLastOSError world
# (res, world) = dup2 pipeStdErrIn STDERR_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdErrOut world
| res == -1 = getLastOSError world
//Exec
# (argv, world) = runProcessMakeArgv [path:args] world
# (res, world) = execvp (path +++ "\0") argv world
= (exit 1 world)
| pid > 0
# (res, world) = close pipeStdInOut world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdOutIn world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdErrIn world
| res == -1 = getLastOSError world
= ( Ok ( { ProcessHandle
| pid = pid
}
# (res, world) = dup2 pipeStdErrIn STDERR_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdErrOut world
| res == -1 = getLastOSError world
# (_, world) = runProcessChildProcessExec path args mCurrentDirectory pipeExecErrorOut pipeExecErrorIn world
// this is never executed as 'childProcessExec' never returns
= (undef, world)
parentProcess :: !Int !Int!Int !Int!Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
parentProcess pipeStdInOut pipeStdInIn pipeStdOutOut pipeStdOutIn pipeStdErrOut pipeStdErrIn pid pipeExecErrorOut pipeExecErrorIn world
# (res, world) = close pipeStdInOut world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdOutIn world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdErrIn world
| res == -1 = getLastOSError world
# (mbPHandle, world) = runProcessParentProcessCheckError pid pipeExecErrorOut pipeExecErrorIn world
| isError mbPHandle = (liftError mbPHandle, world)
= ( Ok ( fromOk mbPHandle
, { stdIn = WritePipe pipeStdInIn
, stdOut = ReadPipe pipeStdOutOut
, stdErr = ReadPipe pipeStdErrOut
......@@ -101,8 +87,62 @@ runProcessIO path args mCurrentDirectory world
)
, world
)
| otherwise
= getLastOSError world
runProcessFork :: !( Int Int *World -> (!MaybeOSError a, !*World))
!(Int Int Int *World -> (!MaybeOSError a, !*World))
!*World
-> (!MaybeOSError a, !*World)
runProcessFork childProcess parentProcess world
// create pipe to pass errors of 'execvp' from child to parent
# (pipeExecError, world) = openPipe world
| isError pipeExecError = (liftError pipeExecError, world)
# (pipeExecErrorOut, pipeExecErrorIn) = fromOk pipeExecError
//Fork
# (pid, world) = fork world
| pid == 0 = childProcess pipeExecErrorOut pipeExecErrorIn world
| pid > 0 = parentProcess pid pipeExecErrorOut pipeExecErrorIn world
| otherwise = getLastOSError world
import StdDebug
// this function never returns, as the process is replaced by 'execvp'
// all errors before 'execvp' succeeds are passed on to the parent process
runProcessChildProcessExec :: !FilePath ![String] !(Maybe String) !Int !Int !*World -> (!MaybeOSError ProcessHandle, !*World)
runProcessChildProcessExec path args mCurrentDirectory pipeExecErrorOut pipeExecErrorIn world
# (res, world) = close pipeExecErrorOut world
| res == -1 = passLastOSErrorToParent pipeExecErrorIn world
// set O_CLOEXEC such that parent is informed if 'execvp' succeeds
# (res, world) = fcntlArg pipeExecErrorIn F_SETFD O_CLOEXEC world
| res == -1 = passLastOSErrorToParent pipeExecErrorIn world
//Chdir
# (res,world) = case mCurrentDirectory of
Just dir -> chdir (packString dir) world
Nothing -> (0, world)
| res <> 0 = passLastOSErrorToParent pipeExecErrorIn world
//Exec
# (argv, world) = runProcessMakeArgv [path:args] world
# (res, world) = execvp (path +++ "\0") argv world
// this part is only executed if 'execvp' failed
// in this case the error is passed to the parent
= passLastOSErrorToParent pipeExecErrorIn world
where
passLastOSErrorToParent :: !Int !*World -> (MaybeOSError ProcessHandle, *World)
passLastOSErrorToParent pipe world
# (errno, world) = errno world
# (mbErr, world) = writePipe (toString errno) (WritePipe pipe) world
| isError mbErr = (liftError mbErr, world)
= exit errno world
runProcessParentProcessCheckError :: !Int !Int !Int !*World -> (!MaybeOSError ProcessHandle, !*World)
runProcessParentProcessCheckError pid pipeExecErrorOut pipeExecErrorIn world
# (res, world) = close pipeExecErrorIn world
| res == -1 = getLastOSError world
// this blocks until either an error is written to the pipe or 'execvp' succeeds
# (mbErrno, world) = readPipeBlocking (ReadPipe pipeExecErrorOut) world
| isError mbErrno = (liftError mbErrno, world)
# errno = fromOk mbErrno
| errno <> "" = (Error (osErrorCodeToOSError (toInt errno)), world)
# (res, world) = close pipeExecErrorOut world
| res == -1 = getLastOSError world
= (Ok {ProcessHandle| pid = pid}, world)
runProcessMakeArgv :: [String] *World -> (!{#Pointer}, *World)
runProcessMakeArgv argv_list world
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment