From e0917e1a5eb16f2d5771b22c0421f25567f0517b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 2 Dec 2008 05:26:45 +0000 Subject: [PATCH] * Added `call-in-sandbox-context'. * Removed `get-namespace' since it's generalized in the above. * Deal with killing the current thread (or the current custodian) in the sandbox code. (Works only without per-expression limits -- still need to find a solution for `call-with-limits'.) * Added tests for this. svn: r12670 --- collects/scheme/sandbox.ss | 32 +++++++++++--------- collects/scribblings/reference/sandbox.scrbl | 14 +++++++-- collects/tests/mzscheme/sandbox.ss | 24 +++++++++++++++ 3 files changed, 52 insertions(+), 18 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index d5dfe981b0..bf47ffc362 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -29,7 +29,7 @@ get-output get-error-output get-uncovered-expressions - get-namespace + call-in-sandbox-context make-evaluator make-module-evaluator call-with-limits @@ -241,16 +241,16 @@ (set! r (with-handlers ([void (lambda (e) (list (p) raise e))]) (call-with-values thunk (lambda vs (list* (p) values vs))))) - (when timer (kill-thread timer))))) - (custodian-shutdown-all c) - (unless r (error 'call-with-limits "internal error")) - ;; apply parameter changes first - (when (car r) (p (car r))) - (if (pair? (cdr r)) - (apply (cadr r) (cddr r)) - (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r)) - (current-continuation-marks) - (cdr r))))))) + (when timer (kill-thread timer)))))) + (custodian-shutdown-all c) + (unless r (error 'call-with-limits "internal error")) + ;; apply parameter changes first + (when (car r) (p (car r))) + (if (pair? (cdr r)) + (apply (cadr r) (cddr r)) + (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r)) + (current-continuation-marks) + (cdr r)))))) (define-syntax with-limits (syntax-rules () @@ -438,7 +438,7 @@ (define-evaluator-messenger get-output 'output) (define-evaluator-messenger get-error-output 'error-output) (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) -(define-evaluator-messenger get-namespace 'namespace) +(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk) (define (make-evaluator* init-hook require-perms program-maker) (define user-cust (make-custodian)) @@ -451,6 +451,7 @@ (define error-output #f) (define limits (sandbox-eval-limits)) (define user-thread #t) ; set later to the thread + (define user-done-evt #t) ; set in the same place (define orig-cust (current-custodian)) (define (limit-thunk thunk) (let* ([sec (and limits (car limits))] @@ -503,7 +504,7 @@ (lambda (e) (user-break) (loop))]) - (channel-get result-ch)))) + (sync user-done-evt result-ch)))) eof)]) (cond [(eof-object? r) (error 'evaluator "terminated")] [(eq? (car r) 'exn) (raise (cdr r))] @@ -541,8 +542,8 @@ [(output) (output-getter output)] [(error-output) (output-getter error-output)] [(uncovered) (apply get-uncovered (evaluator-message-args expr))] - [(namespace) (user-eval (make-evaluator-message - current-namespace '()))] + [(thunk) (user-eval (make-evaluator-message + (car (evaluator-message-args expr)) '()))] [else (error 'evaluator "internal error, bad message: ~e" msg)])) (user-eval expr))) (define linked-outputs? #f) @@ -613,6 +614,7 @@ ;; it will not use the new namespace. [current-eventspace (make-eventspace)]) (set! user-thread (bg-run->thread (run-in-bg user-process))) + (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof))) (let ([r (channel-get result-ch)]) (if (eq? r 'ok) ;; initial program executed ok, so return an evaluator diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index dfa6c9ec07..aa308ac3cf 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -623,10 +623,18 @@ the @scheme[src] argument. Using a sequence of S-expressions (not coverage results, since each expression may be assigned a single source location.} -@defproc[(get-namespace [evaluator (any/c . -> . any)]) - namespace?]{ +@defproc[(call-in-sandbox-context [evaluator (any/c . -> . any)] + [thunk (-> any)]) + any]{ -Retrieves the namespace that is used in an evaluator.} +Calls the given @scheme[thunk] in the context of a sandboxed +evaluator. The call is performed under the resource limits that are +used for evaluating expressions. + +This is usually similar to @scheme[(evaluator (list thunk))], except +that this relies on the common meaning of list expressions as function +application (which is not true in all languages), and it relies on +MzScheme's @scheme[eval] forgiving a non-S-expression input.} @; ---------------------------------------------------------------------- diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 67e5d3dc1f..e829869152 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -363,6 +363,30 @@ ;; (for ([i (in-range 100)]) (display 400k))) ;; =err> "out of memory" + ;; test that killing the custodian works fine + ;; first try it without limits (which imply a nester thread/custodian) + --top-- + (set! ev (parameterize ([sandbox-eval-limits #f]) + (make-evaluator 'scheme/base))) + --eval-- + (kill-thread (current-thread)) =err> "terminated" + --top-- + (set! ev (parameterize ([sandbox-eval-limits #f]) + (make-evaluator 'scheme/base))) + --eval-- + (custodian-shutdown-all (current-custodian)) =err> "terminated" + --top-- + ;; also happens when it's done directly + (set! ev (parameterize ([sandbox-eval-limits #f]) + (make-evaluator 'scheme/base))) + (call-in-sandbox-context ev (lambda () (kill-thread (current-thread)))) + =err> "terminated" + (set! ev (parameterize ([sandbox-eval-limits #f]) + (make-evaluator 'scheme/base))) + (call-in-sandbox-context ev + (lambda () (custodian-shutdown-all (current-custodian)))) + =err> "terminated" + )) (report-errs)