159 lines
5.1 KiB
Racket
159 lines
5.1 KiB
Racket
#lang racket
|
|
(require "status.rkt"
|
|
"notify.rkt"
|
|
"rewriting.rkt"
|
|
"dirstruct.rkt"
|
|
"cache.rkt")
|
|
|
|
(define (command+args+env->command+args
|
|
#:env env
|
|
cmd args)
|
|
(values "/usr/bin/env"
|
|
(append (for/list ([(k v) (in-hash env)])
|
|
(format "~a=~a" k v))
|
|
(list* cmd
|
|
args))))
|
|
|
|
(define (run/collect/wait
|
|
#:env env
|
|
#:timeout timeout
|
|
command args)
|
|
(define start-time
|
|
(current-inexact-milliseconds))
|
|
|
|
; Run the command
|
|
(define-values (new-command new-args)
|
|
(command+args+env->command+args
|
|
#:env env
|
|
command args))
|
|
(define command-line
|
|
(list* command args))
|
|
(define-values
|
|
(the-process stdout stdin stderr)
|
|
(parameterize ([subprocess-group-enabled #t])
|
|
(apply subprocess
|
|
#f #f #f
|
|
new-command
|
|
new-args)))
|
|
|
|
(notify! "Running: ~a ~S" command args)
|
|
|
|
; Run it without input
|
|
(close-output-port stdin)
|
|
|
|
; Wait for all the output and the process death or timeout
|
|
(local
|
|
[(define the-alarm
|
|
(alarm-evt (+ start-time (* 1000 timeout))))
|
|
|
|
(define line-ch (make-channel))
|
|
(define (read-port-t make port)
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define l (read-bytes-line port))
|
|
(if (eof-object? l)
|
|
(channel-put line-ch l)
|
|
(begin (channel-put line-ch (make l))
|
|
(loop)))))))
|
|
(define stdout-t (read-port-t make-stdout stdout))
|
|
(define stderr-t (read-port-t make-stderr stderr))
|
|
|
|
(define final-status
|
|
(let loop ([open-ports 2]
|
|
[end-time #f]
|
|
[status #f]
|
|
[log empty])
|
|
(define process-done? (and end-time #t))
|
|
(define output-done? (zero? open-ports))
|
|
(if (and output-done? process-done?)
|
|
(if status
|
|
(make-exit start-time end-time command-line (reverse log) status)
|
|
(make-timeout start-time end-time command-line (reverse log)))
|
|
(sync (if process-done?
|
|
never-evt
|
|
(choice-evt
|
|
(handle-evt the-alarm
|
|
(λ (_)
|
|
(define end-time
|
|
(current-inexact-milliseconds))
|
|
(subprocess-kill the-process #f)
|
|
(sleep)
|
|
(subprocess-kill the-process #t)
|
|
(loop open-ports end-time status log)))
|
|
(handle-evt the-process
|
|
(λ (_)
|
|
(define end-time
|
|
(current-inexact-milliseconds))
|
|
(loop open-ports end-time (subprocess-status the-process) log)))))
|
|
(if output-done?
|
|
never-evt
|
|
(handle-evt line-ch
|
|
(match-lambda
|
|
[(? eof-object?)
|
|
(loop (sub1 open-ports) end-time status log)]
|
|
[l
|
|
(loop open-ports end-time status (list* l log))])))))))]
|
|
|
|
(close-input-port stdout)
|
|
(close-input-port stderr)
|
|
|
|
(notify! "Done: ~a ~S" command args)
|
|
|
|
final-status))
|
|
|
|
(define-syntax regexp-replace**
|
|
(syntax-rules ()
|
|
[(_ () s) s]
|
|
[(_ ([pat0 subst0]
|
|
[pat subst]
|
|
...)
|
|
s)
|
|
(regexp-replace* (regexp-quote pat0)
|
|
(regexp-replace** ([pat subst] ...) s)
|
|
subst0)]))
|
|
|
|
(define (run/collect/wait/log log-path command
|
|
#:timeout timeout
|
|
#:env env
|
|
args)
|
|
(define ran? #f)
|
|
(cache/file
|
|
log-path
|
|
(lambda ()
|
|
(define rev (number->string (current-rev)))
|
|
(define home (hash-ref env "HOME"))
|
|
(define tmp (hash-ref env "TMPDIR"))
|
|
(define cwd (path->string (current-directory)))
|
|
(define (rewrite s)
|
|
(regexp-replace** ([rev "<current-rev>"]
|
|
[tmp "<tmp>"]
|
|
[home "<home>"]
|
|
[cwd "<cwd>"])
|
|
s))
|
|
|
|
(set! ran? #t)
|
|
(rewrite-status
|
|
#:rewrite rewrite
|
|
(run/collect/wait
|
|
#:timeout timeout
|
|
#:env env
|
|
command args))))
|
|
ran?)
|
|
|
|
(provide/contract
|
|
[command+args+env->command+args
|
|
(string? (listof string?) #:env (hash/c string? string?) . -> . (values string? (listof string?)))]
|
|
[run/collect/wait
|
|
(string?
|
|
#:env (hash/c string? string?)
|
|
#:timeout exact-nonnegative-integer?
|
|
(listof string?)
|
|
. -> . status?)]
|
|
[run/collect/wait/log
|
|
(path-string? string?
|
|
#:env (hash/c string? string?)
|
|
#:timeout exact-nonnegative-integer?
|
|
(listof string?)
|
|
. -> . boolean?)])
|