From c6f377aca8aa44c7e1f1be9cf30564943ab07216 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 9 Apr 2007 09:15:25 +0000 Subject: [PATCH] better output specs and implementation svn: r5903 --- collects/handin-server/sandbox.ss | 6 ++++ collects/mzlib/sandbox.ss | 57 ++++++++++++++++++------------ collects/tests/mzscheme/sandbox.ss | 4 ++- 3 files changed, 44 insertions(+), 23 deletions(-) diff --git a/collects/handin-server/sandbox.ss b/collects/handin-server/sandbox.ss index 6f1248428a..48ceb7e8f7 100644 --- a/collects/handin-server/sandbox.ss +++ b/collects/handin-server/sandbox.ss @@ -2,6 +2,11 @@ (require (lib "sandbox.ss")) (provide (all-from (lib "sandbox.ss"))) + ;; discard all outputs + (sandbox-output #f) + (sandbox-error-output #f) + + ;; share these with evaluators (sandbox-namespace-specs (let ([specs (sandbox-namespace-specs)]) `(,(car specs) @@ -9,6 +14,7 @@ (lib "posn.ss" "lang") ,@(if mred? '((lib "cache-image-snip.ss" "mrlib")) '())))) + ;; local overrides (sandbox-override-collection-paths (cons (build-path (collection-path "handin-server") "overridden-collects") (sandbox-override-collection-paths))) diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss index 27f77db42d..90e3dff4b9 100644 --- a/collects/mzlib/sandbox.ss +++ b/collects/mzlib/sandbox.ss @@ -40,7 +40,7 @@ (define sandbox-init-hook (make-parameter void)) (define sandbox-input (make-parameter #f)) (define sandbox-output (make-parameter #f)) - (define sandbox-error-output (make-parameter #t)) + (define sandbox-error-output (make-parameter current-error-port)) (define sandbox-eval-limits (make-parameter '(30 10))) ; 30sec, 10mb (define sandbox-coverage-enabled (make-parameter #f)) @@ -350,6 +350,7 @@ (define current-eventspace (mz/mr (make-parameter #f) current-eventspace)) (define make-eventspace (mz/mr void make-eventspace)) (define run-in-bg (mz/mr thread queue-callback)) + (define bg-run->thread (mz/mr values eventspace-handler-thread)) (define null-input (open-input-bytes #"")) (define (kill-evaluator eval) (eval kill-evaluator)) @@ -376,9 +377,14 @@ (define output #f) (define error-output #f) (define limits (sandbox-eval-limits)) - (define user-running? #t) + (define user-thread #t) ; set later to the thread + (define orig-cust (current-custodian)) (define (kill-me) - (when user-running? (set! user-running? #f) (custodian-shutdown-all cust)) + (when user-thread + (let ([t user-thread]) + (set! user-thread #f) + (custodian-shutdown-all cust) + (kill-thread t))) ; just in case (void)) (define (user-process) (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) @@ -407,7 +413,7 @@ (cons 'vals (call-with-values run list)))))) (loop (add1 n))))) (define (user-eval expr) - (let ([r (if user-running? + (let ([r (if user-thread (begin (channel-put input-ch expr) (channel-get result-ch)) eof)]) (cond [(eof-object? r) (error 'evaluator "terminated")] @@ -437,30 +443,32 @@ (define linked-outputs? #f) (define (make-output what out set-out! allow-link?) (cond [(not out) (open-output-nowhere)] - [(and (eq? #t out) allow-link?) - (set! linked-outputs? #t) (current-output-port)] + [(and (procedure? out) (procedure-arity-includes? out 0)) (out)] [(output-port? out) out] [(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)] [(memq out '(bytes string)) - (let-values ([(open get) - (if (eq? out 'bytes) - (values open-output-bytes get-output-bytes) - (values open-output-string get-output-string))]) - (let ([o (open)]) - (set-out! (lambda () - (let ([o1 o]) - (set! o (open)) - (current-output-port o) - (when linked-outputs? (current-error-port o)) - (get o1)))) - o))] + (let* ([bytes? (eq? 'bytes out)] + ;; the following doesn't really matter: they're the same + [out ((if bytes? open-output-bytes open-output-string))]) + (set-out! + (lambda () + (parameterize ([current-custodian orig-cust]) + (let ([running? (and (thread? user-thread) + (thread-running? user-thread))]) + (when running? (thread-suspend user-thread)) + (let ([buf (subbytes (get-output-bytes out) + 0 (file-position out))]) + (file-position out 0) + (when running? (thread-resume user-thread)) + (if bytes? buf (bytes->string/utf-8 buf #\?))))))) + out)] [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) (parameterize* ; the order in these matters - ([current-custodian cust] + (;; create a sandbox context first + [current-custodian cust] [current-thread-group (make-thread-group)] [current-namespace (make-evaluation-namespace)] - [current-inspector (make-inspector)] - [exit-handler (lambda x (error 'exit "user code cannot exit"))] + ;; set up the IO context [current-input-port (let ([inp (sandbox-input)]) (if inp @@ -473,6 +481,7 @@ [current-error-port (make-output 'error-output (sandbox-error-output) (lambda (o) (set! error-output o)) #t)] + ;; paths [current-library-collection-paths (filter directory-exists? (append (sandbox-override-collection-paths) @@ -482,7 +491,11 @@ (current-library-collection-paths)) require-perms (sandbox-path-permissions))] + ;; restrict the sandbox context from this point [current-security-guard (sandbox-security-guard)] + [exit-handler (lambda x (error 'exit "user code cannot exit"))] + [current-inspector (make-inspector)] + ;; This breaks: [current-code-inspector (make-inspector)] ;; Note the above definition of `current-eventspace': in MzScheme, it ;; is an unused parameter. Also note that creating an eventspace ;; starts a thread that will eventually run the callback code (which @@ -490,7 +503,7 @@ ;; must be nested in the above (which is what paramaterize* does), or ;; it will not use the new namespace. [current-eventspace (make-eventspace)]) - (run-in-bg user-process) + (set! user-thread (bg-run->thread (run-in-bg user-process))) (let ([r (channel-get result-ch)]) (if (eq? r 'ok) ;; initial program executed ok, so return an evaluator diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index ccda20c931..5598c9df6f 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -67,7 +67,9 @@ ;; i/o --top-- - (set! ev (parameterize ([sandbox-input "3\n"] [sandbox-output 'string]) + (set! ev (parameterize ([sandbox-input "3\n"] + [sandbox-output 'string] + [sandbox-error-output current-output-port]) (make-evaluator 'mzscheme '() '(define x 123)))) --eval-- (printf "x = ~s\n" x) => (void) --top-- (get-output ev) => "x = 123\n"