From 3d0a581f88189b1d9c8f6ec6ba7587eca01f3d6c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 26 Mar 2007 01:21:44 +0000 Subject: [PATCH] per-expression limits svn: r5828 --- collects/handin-server/doc.txt | 64 ++++++---- collects/handin-server/sandbox.ss | 187 ++++++++++++++++-------------- 2 files changed, 141 insertions(+), 110 deletions(-) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 8ca9fbaed4..d14cba5854 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -644,12 +644,6 @@ by this function. (which means that the contents may be unreliable, but the position is). The default is `#f'. -> (get-uncovered-expressions evaluator) - When this is used with an evaluator that was created with - `make-evaluator', it will return a list of uncovered syntax - objects. (It can also be provided as an argument to the evaluator, - with the same result.) - > namespace-specs A parameter that holds a list of values that specify how to create a namespace for evaluation in `make-evaluator'. The first item in the @@ -724,18 +718,17 @@ by this function. `get-output' returns the input end of the pipe. (Note that error output is *not* redirected.) -> (get-output evaluator) - When this is used with an evaluator that was created with - `make-evaluator', it will return the output of the evaluator. (It - can also be provided as an argument to the evaluator, with the same - result.) The result depends on the value of the `sandbox-output' - parameter at the time the evaluator was created: if it was `#f' then - `get-output' will return `#f', if it was the symbol `pipe' then - `get-output' returns an input port that is being fed by the pipe, - and if it was the symbol `bytes' or `string' then `get-output' - returns the accumulated output and resets the evaluator's output to - a new output string or byte string (so each call returns a piece of - the evaluator's output). +> sandbox-eval-limits + A parameter that determines the default limits on each use of a + `make-evaluator' function. Its value should be a list of two + numbers, the first is a timeout value in seconds, and the second is + for setting a memory limit in megabytes. Either one can be `#f' for + disabling the corresponding limit (or the parameter can be set to + `#f' to disble both). When limits are set `with-limits' (see blow) + is wrapped around any use of an evaluator, so consuming too much + time or memory results in an exception. After an evaluator is + generated, its limits can be modified using `set-eval-limits' below + (the parameter value is used to initialize a new evaluator). > (make-evaluator language teachpack-paths input-program) This is the main entry point for the sandbox module. @@ -774,15 +767,46 @@ by this function. See also `with-limits' below for adding resource limits, and `get-uncovered-expressions' above for enforcing test coverage. +> (get-output evaluator) + When this is used with an evaluator that was created with + `make-evaluator', it will return the output of the evaluator. (It + can also be provided as an argument to the evaluator, with the same + result.) The result depends on the value of the `sandbox-output' + parameter at the time the evaluator was created: if it was `#f' then + `get-output' will return `#f', if it was the symbol `pipe' then + `get-output' returns an input port that is being fed by the pipe, + and if it was the symbol `bytes' or `string' then `get-output' + returns the accumulated output and resets the evaluator's output to + a new output string or byte string (so each call returns a piece of + the evaluator's output). + +> (get-uncovered-expressions evaluator) + When this is used with an evaluator that was created with + `make-evaluator', it will return a list of uncovered syntax + objects. (It can also be provided as an argument to the evaluator, + with the same result.) + +> (set-eval-limits evaluator sec mb) + Changes the per-expression limits that the evaluator uses. This + procedure should be used to modify an evaluator limits -- changing + the `sandbox-eval-limits' parameter (see above) does not affect + existing evaluators. See also `with-limits' below. + > (call-with-limits sec mb thunk) This function executes the given thunk with memory and time restrictions: if execution consumes more than `mb' megabytes or more that `sec' seconds, then the computation is aborted and an error is thrown. Otherwise the result of the thunk is returned (a value, multiple values, or raise an exception). Each of the two limits can - be `#f' to disable it. + be `#f' to disable it. (Note: memory limits requires running in a + 3m executable.) - (Note: memory limit requires running in a 3m executable.) + This is used in `make-evaluator' functions, according to the + `sandbox-eval-limits' setting and uses of `set-eval-limits': each + expression evaluation is protected from timeouts and memory + problems. This means that you normally would not use it -- but you + may want to limit a whole testing session instead of each expression + (eg, when you want to run tests faster). > (with-limits sec mb body ...) A macro version of the above. diff --git a/collects/handin-server/sandbox.ss b/collects/handin-server/sandbox.ss index 6885bd88c2..c9f994b418 100644 --- a/collects/handin-server/sandbox.ss +++ b/collects/handin-server/sandbox.ss @@ -11,8 +11,10 @@ sandbox-path-permissions sandbox-input sandbox-output + sandbox-eval-limits get-output get-uncovered-expressions + set-eval-limits make-evaluator call-with-limits with-limits) @@ -30,7 +32,7 @@ (define sandbox-input (make-parameter #f)) (define sandbox-output (make-parameter #f)) - (define null-input (open-input-bytes #"")) + (define sandbox-eval-limits (make-parameter '(30 10))) ; 30sec, 10mb (define coverage-enabled (make-parameter #f)) @@ -264,99 +266,104 @@ (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 null-input (open-input-bytes #"")) (define (get-uncovered-expressions eval) (eval get-uncovered-expressions)) - (define (get-output eval) (eval get-output)) + (define (get-output eval) (eval get-output)) + (define (set-eval-limits eval . args) (apply (eval set-eval-limits) args)) (define (make-evaluator language teachpacks input-program) - (let ([coverage-enabled (coverage-enabled)] - [uncovered-expressions #f] - [input-ch (make-channel)] - [result-ch (make-channel)] - [output #f]) - (parameterize - ([current-namespace (make-evaluation-namespace)] - [current-inspector (make-inspector)] - [current-library-collection-paths - (filter directory-exists? - (append (sandbox-override-collection-paths) - (current-library-collection-paths)))] - [exit-handler (lambda x (error 'exit "user code cannot exit"))] - [current-input-port - (let ([inp (sandbox-input)]) (if inp (input->port inp) null-input))] - [current-output-port - (let ([out (sandbox-output)]) - (cond [(not out) (open-output-nowhere)] - [(output-port? out) (set! output out) out] - [(eq? out 'pipe) - (let-values ([(i o) (make-pipe)]) (set! output 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! output (lambda () - (let ([o1 o]) - (set! o (open)) - (current-output-port o) - (get-output-bytes o1)))) - o))] - [else (error 'make-evaluator "bad output: ~e" out)]))] - [sandbox-path-permissions - (append (sandbox-path-permissions) - (get-lib-permissions (sandbox-override-collection-paths)) - (require-perms language teachpacks))] - [current-security-guard (sandbox-security-guard)]) - ;; Note the above definition of `current-eventspace': in MzScheme, it - ;; is a parameter that is not used at all. Also note that creating an - ;; eventspace starts a thread that will eventually run the callback - ;; code (which evaluates the program in `run-in-bg') -- so this - ;; parameterization must be nested in the above, or it will not use the - ;; new namespace. - (parameterize ([current-eventspace (make-eventspace)]) - (run-in-bg - (lambda () - ;; First read program and evaluate it as a module: - (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) - (evaluate-program - language teachpacks input-program - (and coverage-enabled - (lambda (exprs) (set! uncovered-expressions exprs)))) - (channel-put result-ch 'ok)) - ;; Now wait for interaction expressions: - (let loop () - (let ([expr (channel-get input-ch)]) - (unless (eof-object? expr) - (with-handlers ([void (lambda (exn) - (channel-put result-ch - (cons 'exn exn)))]) - (channel-put result-ch - (cons 'vals (call-with-values - (lambda () (eval expr)) - list)))) - (loop)))) - (let loop () - (channel-put result-ch '(exn . no-more-to-evaluate)) - (loop)))) - (let ([r (channel-get result-ch)]) - (define (eval-in-user-context expr) - (channel-put input-ch expr) - (let ([r (channel-get result-ch)]) - (if (eq? (car r) 'exn) (raise (cdr r)) (apply values (cdr r))))) - (if (eq? r 'ok) - ;; Initial program executed ok, so return an evaluator: - (lambda (expr) - (cond [(eq? expr get-uncovered-expressions) - uncovered-expressions] - [(eq? expr get-output) - (if (procedure? output) - (eval-in-user-context `(,output)) - output)] - [else (eval-in-user-context expr)])) - ;; Program didn't execute: - (raise r))))))) + (define coverage? (coverage-enabled)) + (define uncovered-expressions #f) + (define input-ch (make-channel)) + (define result-ch (make-channel)) + (define output #f) + (define limits (sandbox-eval-limits)) + (define (user-process) + ;; First read program and evaluate it as a module: + (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) + (evaluate-program + language teachpacks input-program + (and coverage? (lambda (exprs) (set! uncovered-expressions exprs)))) + (channel-put result-ch 'ok)) + ;; Now wait for interaction expressions: + (let loop () + (let ([expr (channel-get input-ch)]) + (unless (eof-object? expr) + (with-handlers ([void (lambda (exn) + (channel-put result-ch (cons 'exn exn)))]) + (let* ([sec (and limits (car limits))] + [mb (and limits (cadr limits))] + [run (if (or sec mb) + (lambda () (with-limits sec mb (eval expr))) + (lambda () (eval expr)))]) + (channel-put result-ch + (cons 'vals (call-with-values run list))))) + (loop)))) + (let loop () + (channel-put result-ch '(exn . nothing-more-to-evaluate)) + (loop))) + (define (user-eval expr) + (channel-put input-ch expr) + (let ([r (channel-get result-ch)]) + (if (eq? (car r) 'exn) (raise (cdr r)) (apply values (cdr r))))) + (define (evaluator expr) + (cond [(eq? expr get-output) + (if (procedure? output) (user-eval `(,output)) output)] + [(eq? expr get-uncovered-expressions) + uncovered-expressions] + [(eq? expr set-eval-limits) + (lambda args (set! limits args))] + [else (user-eval expr)])) + (parameterize + ([current-namespace (make-evaluation-namespace)] + [current-inspector (make-inspector)] + [current-library-collection-paths + (filter directory-exists? + (append (sandbox-override-collection-paths) + (current-library-collection-paths)))] + [exit-handler (lambda x (error 'exit "user code cannot exit"))] + [current-input-port + (let ([inp (sandbox-input)]) (if inp (input->port inp) null-input))] + [current-output-port + (let ([out (sandbox-output)]) + (cond [(not out) (open-output-nowhere)] + [(output-port? out) (set! output out) out] + [(eq? out 'pipe) + (let-values ([(i o) (make-pipe)]) (set! output 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! output (lambda () + (let ([o1 o]) + (set! o (open)) + (current-output-port o) + (get-output-bytes o1)))) + o))] + [else (error 'make-evaluator "bad output: ~e" out)]))] + [sandbox-path-permissions + (append (sandbox-path-permissions) + (get-lib-permissions (sandbox-override-collection-paths)) + (require-perms language teachpacks))] + [current-security-guard (sandbox-security-guard)]) + ;; Note the above definition of `current-eventspace': in MzScheme, it is + ;; a parameter that is not used at all. Also note that creating an + ;; eventspace starts a thread that will eventually run the callback code + ;; (which evaluates the program in `run-in-bg') -- so this + ;; parameterization must be nested in the above, or it will not use the + ;; new namespace. + (parameterize ([current-eventspace (make-eventspace)]) + (run-in-bg user-process) + (let ([r (channel-get result-ch)]) + (if (eq? r 'ok) + ;; Initial program executed ok, so return an evaluator: + evaluator + ;; Program didn't execute: + (raise r)))))) ;; Resources ----------------------------------------------------------------