diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 0e86c68da3..248636f809 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -39,6 +39,8 @@ call-in-nested-thread* call-with-limits with-limits + exn:fail:sandbox-terminated? + exn:fail:sandbox-terminated-reason exn:fail:resource? exn:fail:resource-resource) @@ -152,8 +154,8 @@ 'sandbox-security-guard "security-guard or a security-guard translator procedure" x))))) -(define (default-sandbox-exit-handler _) - (error 'exit "sandboxed code cannot exit")) +;; this is never really used (see where it's used in the evaluator) +(define (default-sandbox-exit-handler _) (error 'exit "sandbox exits")) (define sandbox-exit-handler (make-parameter default-sandbox-exit-handler)) @@ -516,6 +518,14 @@ (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) (define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk) + +(define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent) +(define (make-terminated reason) + (make-exn:fail:sandbox-terminated + (format "evaluator: terminated (~a)" reason) + (current-continuation-marks) + reason)) + (define (make-evaluator* init-hook allow program-maker) (define orig-code-inspector (current-code-inspector)) (define orig-cust (current-custodian)) @@ -532,6 +542,12 @@ (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 terminated? #f) ; set to an exception value when the sandbox dies + (define (terminated! reason) + (unless terminated? + (set! terminated? + (make-terminated ; use #f to detect internal errors + (or reason "internal error: no termination reason"))))) (define (limit-thunk thunk) (let* ([sec (and limits (car limits))] [mb (and limits (cadr limits))]) @@ -540,6 +556,7 @@ (when user-thread (let ([t user-thread]) (set! user-thread #f) + (terminated! #f) (custodian-shutdown-all user-cust) (kill-thread t))) ; just in case (void)) @@ -560,7 +577,8 @@ (let ([n 0]) (let loop () (let ([expr (channel-get input-ch)]) - (when (eof-object? expr) (channel-put result-ch expr) (user-kill)) + (when (eof-object? expr) + (terminated! 'eof) (channel-put result-ch expr) (user-kill)) (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) (define run @@ -585,9 +603,12 @@ (loop))]) (sync user-done-evt result-ch)))) eof)]) - (cond [(eof-object? r) (error 'evaluator "terminated~a" - (if (custodian-box-value memory-cust-box) - "" " (memory exceeded)"))] + (cond [(eof-object? r) + (unless terminated? + (if (custodian-box-value memory-cust-box) + (terminated! 'out-of-memory) + (terminated! #f))) + (raise terminated?)] [(eq? (car r) 'exn) (raise (cdr r))] [else (apply values (cdr r))]))) (define get-uncovered @@ -617,7 +638,7 @@ (let ([msg (evaluator-message-msg expr)]) (case msg [(alive?) (and user-thread (not (thread-dead? user-thread)))] - [(kill) (user-kill)] + [(kill) (terminated! 'evaluator-killed) (user-kill)] [(break) (user-break)] [(limits) (set! limits (evaluator-message-args expr))] [(input) (apply input-putter (evaluator-message-args expr))] @@ -687,7 +708,11 @@ ;; restrict the sandbox context from this point [current-security-guard (let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))] - [exit-handler (sandbox-exit-handler)] + [exit-handler + (let ([h (sandbox-exit-handler)]) + (if (eq? h default-sandbox-exit-handler) + (lambda _ (terminated! 'exited) (user-kill)) + h))] [current-inspector ((sandbox-make-inspector))] [current-logger ((sandbox-make-logger))] [current-code-inspector (make-inspector)] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 77dd47a34c..229f638c82 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -243,6 +243,19 @@ used from a module (by using a new namespace): } + +@defproc*[([(exn:fail:sandbox-terminated? [v any/c]) boolean?] + [(exn:fail:sandbox-terminated-reason [exn exn:fail:sandbox-terminated?]) + symbol/c])]{ + +A predicate and accessor for exceptions that are raised when a sandbox +is terminated. Once a sandbox raises such an exception, it will +continue to raise it on further evaluation attempts. + +@scheme[call-with-limits]. The @scheme[resource] field holds a symbol, +either @scheme['time] or @scheme['memory].} + + @; ---------------------------------------------------------------------- @section{Customizing Evaluators} @@ -472,7 +485,9 @@ network connection.} @defparam[sandbox-exit-handler handler (any/c . -> . any)]{ A parameter that determines the initial @scheme[(exit-handler)] for -sandboxed evaluations. The default handler simply throws an error.} +sandboxed evaluations. The default kills the evaluator with an +appropriate error message (see +@scheme[exn:fail:sandbox-terminated-reason]).} @defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{ diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index eb33961365..a59909c3bb 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -130,12 +130,16 @@ (thread (lambda () (sleep 1) (break-evaluator ev))) --eval-- (sleep 2) =err> "user break" + (printf "x = ~s\n" x) => (void) ;; termination --eval-- - (printf "x = ~s\n" x) => (void) - ,eof =err> "terminated" - x =err> "terminated" - ,eof =err> "terminated" + ,eof =err> "terminated .eof.$" + 123 =err> "terminated .eof.$" + ,eof =err> "terminated .eof.$" + + ;; other termination messages + --top-- (set! ev (make-evaluator 'scheme/base)) (kill-evaluator ev) + --eval-- 123 =err> "terminated .evaluator-killed." ;; eval-limits apply to the sandbox creation too --top-- @@ -198,9 +202,9 @@ --top-- (kill-evaluator ev) => (void) --eval-- - x =err> "terminated" - y =err> "terminated" - ,eof =err> "terminated" + x =err> "terminated .evaluator-killed." + y =err> "terminated .evaluator-killed." + ,eof =err> "terminated .evaluator-killed." --top-- (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) ;; o1 -> i1 -ev-> o2 -> i2