Process.icl 13.3 KB
Newer Older
1
implementation module System.Process
Bas Lijnse's avatar
Bas Lijnse committed
2 3 4 5 6 7 8 9 10

//StdEnv
import StdArray
import StdBool
import StdClass
import StdInt
import StdList
import StdString
import StdMisc
11
import StdFunc
Bas Lijnse's avatar
Bas Lijnse committed
12 13

//Data
14
import Data.Maybe
15
from Data.List import maximum
Bas Lijnse's avatar
Bas Lijnse committed
16 17

//System
18 19 20 21 22
import System.FilePath
import System.File
import System.OSError
import System._Pointer
import System._Posix
Bas Lijnse's avatar
Bas Lijnse committed
23

24 25 26
:: WritePipe = WritePipe !Int
:: ReadPipe  = ReadPipe  !Int

Bas Lijnse's avatar
Bas Lijnse committed
27
runProcess :: !FilePath ![String] !(Maybe String) !*World -> (MaybeOSError ProcessHandle, *World)
28 29 30 31
runProcess path args mCurrentDirectory world = runProcessFork
    (runProcessChildProcessExec path args mCurrentDirectory)
    runProcessParentProcessCheckError
    world
Bas Lijnse's avatar
Bas Lijnse committed
32

33
runProcessIO :: !FilePath ![String] !(Maybe String) !*World -> (MaybeOSError (ProcessHandle, ProcessIO), *World)
34
runProcessIO path args mCurrentDirectory world
35 36 37 38 39 40 41 42 43 44 45 46
    // StdIn
    # (pipeStdIn, world) = openPipe world
    | isError pipeStdIn = (liftError pipeStdIn, world)
    # (pipeStdInOut, pipeStdInIn) = fromOk pipeStdIn
    // StdOut
    # (pipeStdOut, world) = openPipe world
    | isError pipeStdOut = (liftError pipeStdOut, world)
    # (pipeStdOutOut, pipeStdOutIn) = fromOk pipeStdOut
    // StdErr
    # (pipeStdErr, world) = openPipe world
    | isError pipeStdErr = (liftError pipeStdErr, world)
    # (pipeStdErrOut, pipeStdErrIn) = fromOk pipeStdErr
47 48 49 50 51 52
    = 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
53
        //redirect stdin/out/err to pipes
54 55 56 57
        # (res, world) = dup2 pipeStdInOut STDIN_FILENO world
        | res == -1    = getLastOSError world
        # (res, world) = close pipeStdInIn world
        | res == -1    = getLastOSError world
58

59 60 61 62
        # (res, world) = dup2 pipeStdOutIn STDOUT_FILENO world
        | res == -1    = getLastOSError world
        # (res, world) = close pipeStdOutOut world
        | res == -1    = getLastOSError world
63

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
        # (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
83 84 85
               , { stdIn  = WritePipe pipeStdInIn
                 , stdOut = ReadPipe  pipeStdOutOut
                 , stdErr = ReadPipe  pipeStdErrOut
86 87 88 89
                 }
               )
          , world
          )
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

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
Steffen Michels's avatar
Steffen Michels committed
105

106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
// 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
130 131
        # (_, world)     = writePipe (toString errno) (WritePipe pipe) world
        // potential error of 'writePipe' cannot be handled properly
132 133 134 135 136 137 138 139 140 141 142 143 144 145
	    = 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)
146 147 148 149 150 151 152 153 154

runProcessMakeArgv :: [String] *World -> (!{#Pointer}, *World)
runProcessMakeArgv argv_list world
	# args_size = argvLength argv_list 0
	  args_string = createArgsString args_size argv_list
	  args_memory = malloc args_size
	| args_memory == 0
		= abort "malloc failed"
	# args_memory = memcpy_string_to_pointer args_memory args_string args_size
155
	# (argv, args_memory) = readP (createArgv argv_list) args_memory
156
    # world = freeSt args_memory world
157
	= (argv, world)
158
where
159 160 161 162 163 164 165 166
	argvLength [a:as] l
		= argvLength as (l+((size a +(IF_INT_64_OR_32 8 4)) bitand (IF_INT_64_OR_32 -8 -4)))
	argvLength [] l
		= l

	createArgsString args_size argv_list
		# s = createArray args_size '\0'
		= copyArgs argv_list 0 s
167
	where
168 169 170 171 172
		copyArgs [a:as] i s
			# s = copyChars 0 a i s
			= copyArgs as (i+((size a +(IF_INT_64_OR_32 8 4)) bitand (IF_INT_64_OR_32 -8 -4))) s
		copyArgs [] i s
			= s
173

174 175 176 177 178 179
		copyChars :: !Int !{#Char} !Int !*{#Char} -> *{#Char}
		copyChars ai a si s
			| ai<size a
				# s = {s & [si]=a.[ai]}
				= copyChars (ai+1) a (si+1) s
			= s
180

181 182 183 184 185 186 187 188 189 190 191 192
	createArgv argv_list args_memory
		# n_args = length argv_list
		# argv = createArray (n_args+1) 0;
		= fillArgv 0 argv_list argv args_memory 
	where
		fillArgv :: !Int ![{#Char}] !*{#Pointer} !Int -> *{#Pointer}
		fillArgv arg_n [a:as] argv args_memory
			# argv = {argv & [arg_n]=args_memory}
			  args_memory = args_memory + ((size a +(IF_INT_64_OR_32 8 4)) bitand (IF_INT_64_OR_32 -8 -4))
			= fillArgv (arg_n+1) as argv args_memory
		fillArgv arg_n [] argv args_memory
			= {argv & [arg_n]=0}
193 194 195

openPipe :: !*World -> (MaybeOSError (Int, Int), !*World)
openPipe world
196
    # ptr = malloc 8
197
    | ptr == 0 = abort "malloc failed"
198
    # (res, world) = pipe ptr world
199
    | res == -1
200
        # world = freeSt ptr world
201 202 203
        = getLastOSError world
    # (rEnd, ptr)  = readP (\ptr -> readInt4S ptr 0) ptr
    # (wEnd, ptr)  = readP (\ptr -> readInt4S ptr 4) ptr
204
    # world = freeSt ptr world
205 206
    = (Ok (rEnd, wEnd), world)

Bas Lijnse's avatar
Bas Lijnse committed
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
checkProcess :: !ProcessHandle !*World -> (MaybeOSError (Maybe Int), *World)
checkProcess {pid} world
	# status		= createArray 1 0
	# (ret,world)	= waitpid pid status WNOHANG world //Non-blocking wait :)
	| ret == 0
		= (Ok Nothing, world)	
	| ret == pid	
		# exitCode = (status.[0] >> 8) bitand 0xFF
		= (Ok (Just exitCode), world)
	| otherwise
		= getLastOSError world

waitForProcess :: !ProcessHandle !*World -> (!MaybeOSError Int, !*World)
waitForProcess {pid} world
	# status		= createArray 1 0
	# (ret,world)	= waitpid pid status 0 world //Blocking wait
	| ret == pid
		# exitCode = (status.[0] >> 8) bitand 0xFF
		= (Ok exitCode, world)
	| otherwise
		= getLastOSError world

	
callProcess :: !FilePath ![String] !(Maybe String) !*World -> (MaybeOSError Int, *World)
callProcess path args mCurrentDirectory world
	# (res, world) = runProcess path args mCurrentDirectory world
	= case res of 
		Ok handle	= waitForProcess handle world
		Error e		= (Error e, world)
236 237 238 239

readPipeNonBlocking :: !ReadPipe !*World -> (!MaybeOSError String, !*World)
readPipeNonBlocking (ReadPipe fd) world
    # ptr           = malloc 4
240
    # (res, world) = ioctl fd FIONREAD ptr world
241
    | res == -1
242
        # world = freeSt ptr world
243
        = getLastOSError world
244
    # (n, ptr)      = readP (\ptr -> readInt4Z ptr 0) ptr
245
    # world         = freeSt ptr world
246 247
    | n == 0        = (Ok "", world)
    # buffer        = malloc n
248
    # (res, world) = read fd buffer n world
249
    | res == -1
250
        # world = freeSt buffer world
251
        = getLastOSError world
252 253
    # (str, buffer) = readP (\ptr -> derefCharArray ptr n) buffer
    # world = freeSt buffer world
254 255 256 257 258 259
    = (Ok str, world)

readPipeBlocking :: !ReadPipe !*World -> (!MaybeOSError String, !*World)
readPipeBlocking pipe=:(ReadPipe fd) world
    # readfds = malloc 128
    // init array
260
    # readfds = seq [\ptr -> writeIntElemOffset ptr i 0 \\ i <- [0..IF_INT_64_OR_32 15 31]] readfds
261
    // set bit for fd
262
    # readfds = readPipeBlockingSetFdBit fd readfds
263
    // wait
264 265
    # (res, world) = select_ (fd + 1) readfds 0 0 0 world
    # world = freeSt readfds world
266
    | res == -1 = getLastOSError world
267 268
    = readPipeNonBlocking pipe world

269 270 271 272
readPipeBlockingMulti :: ![ReadPipe] !*World -> (!MaybeOSError [String], !*World)
readPipeBlockingMulti pipes world
    #readfds = malloc 128
    // init array
273
    #readfds = seq [\ptr -> writeIntElemOffset ptr i 0 \\ i <- [0..IF_INT_64_OR_32 15 31]] readfds
274
    // set bits for fds
275
    #readfds = seq [readPipeBlockingSetFdBit fd \\ ReadPipe fd <- pipes] readfds
276
    // wait
277 278
    # (res, world) = select_ (maxFd + 1) readfds 0 0 0 world
    # world = freeSt readfds world
279
    | res == -1 = getLastOSError world
280 281 282 283 284 285 286 287 288 289 290
    = seq [ \(res, world) -> case res of
                Ok res`
                    #(r, world) = readPipeNonBlocking pipe world
                    = (seqErrors r (\r` -> Ok [r`:res`]), world)
                error =  (error, world)
            \\ pipe <- reverse pipes
          ]
          (Ok [], world)
where
    maxFd = maximum [fd \\ ReadPipe fd <- pipes]

291 292 293 294 295
readPipeBlockingSetFdBit :: !Int !Pointer -> Pointer
readPipeBlockingSetFdBit fd ptr
    # offset  = fromInt fd / IF_INT_64_OR_32 64 32
    # val = (readIntElemOffset ptr offset) bitor (1 << (fd rem IF_INT_64_OR_32 64 32))
    = writeIntElemOffset ptr offset val
296 297 298 299 300 301 302

writePipe :: !String !WritePipe !*World -> (!MaybeOSError (), !*World)
writePipe str (WritePipe fd) world
    #(res, world) = write fd str (size str) world
    | res == -1 = getLastOSError world
    = (Ok (), world)

303 304
terminateProcess :: !ProcessHandle !*World -> (!MaybeOSError (), !*World)
terminateProcess pHandle=:{pid} world
305 306
    # (res, world) = kill pid 15 world // Termination signal
    | res == -1    = getLastOSError world
307 308 309 310
    // otherwise process will remain as zombie
    # status       = createArray 1 0
    # (res, world) = waitpid pid status 0 world
    | res == -1    = getLastOSError world
311 312 313 314 315 316 317 318 319 320 321 322
    = (Ok (), world)

closeProcessIO :: !ProcessIO !*World -> (!MaybeOSError (), !*World)
closeProcessIO {stdIn = WritePipe fdStdIn, stdOut = ReadPipe fdStdOut, stdErr = ReadPipe fdStdErr} world
    # (res, world) = close fdStdIn world
    | res == -1    = getLastOSError world
    # (res, world) = close fdStdOut world
    | res == -1    = getLastOSError world
    # (res, world) = close fdStdErr world
    | res == -1    = getLastOSError world
    = (Ok (), world)

323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
instance closePipe WritePipe
where
    closePipe :: !WritePipe !*World -> (!MaybeOSError (), !*World)
    closePipe (WritePipe pipe) world = closePipe` pipe world

instance closePipe ReadPipe
where
    closePipe :: !ReadPipe !*World -> (!MaybeOSError (), !*World)
    closePipe (ReadPipe pipe) world = closePipe` pipe world

closePipe` :: !Int !*World -> (!MaybeOSError (), !*World)
closePipe` pipe world
	# (res, world) = close pipe world
	| res <> 0     = getLastOSError world
	= (Ok (), world)