suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

per-expression limits

Browse Source 
svn: r5828
This commit is contained in:
Eli Barzilay 2007-03-26 01:21:44 +00:00
parent da6e732918
commit 3d0a581f88
2 changed files with 141 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/handin-server/doc.txt
View File

@ -644,12 +644,6 @@ by this function.
(which means that the contents may be unreliable, but the position (which means that the contents may be unreliable, but the position
is). The default is `#f'. 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 > namespace-specs
A parameter that holds a list of values that specify how to create a 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 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. `get-output' returns the input end of the pipe.
(Note that error output is *not* redirected.) (Note that error output is *not* redirected.)
> (get-output evaluator) > sandbox-eval-limits
When this is used with an evaluator that was created with A parameter that determines the default limits on each use of a
`make-evaluator', it will return the output of the evaluator. (It `make-evaluator' function. Its value should be a list of two
can also be provided as an argument to the evaluator, with the same numbers, the first is a timeout value in seconds, and the second is
result.) The result depends on the value of the `sandbox-output' for setting a memory limit in megabytes. Either one can be `#f' for
parameter at the time the evaluator was created: if it was `#f' then disabling the corresponding limit (or the parameter can be set to
`get-output' will return `#f', if it was the symbol `pipe' then `#f' to disble both). When limits are set `with-limits' (see blow)
`get-output' returns an input port that is being fed by the pipe, is wrapped around any use of an evaluator, so consuming too much
and if it was the symbol `bytes' or `string' then `get-output' time or memory results in an exception. After an evaluator is
returns the accumulated output and resets the evaluator's output to generated, its limits can be modified using `set-eval-limits' below
a new output string or byte string (so each call returns a piece of (the parameter value is used to initialize a new evaluator).
the evaluator's output).
> (make-evaluator language teachpack-paths input-program) > (make-evaluator language teachpack-paths input-program)
This is the main entry point for the sandbox module. 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 See also `with-limits' below for adding resource limits, and
`get-uncovered-expressions' above for enforcing test coverage. `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) > (call-with-limits sec mb thunk)
This function executes the given thunk with memory and time This function executes the given thunk with memory and time
restrictions: if execution consumes more than `mb' megabytes or more restrictions: if execution consumes more than `mb' megabytes or more
that `sec' seconds, then the computation is aborted and an error is that `sec' seconds, then the computation is aborted and an error is
thrown. Otherwise the result of the thunk is returned (a value, thrown. Otherwise the result of the thunk is returned (a value,
multiple values, or raise an exception). Each of the two limits can 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 ...) > (with-limits sec mb body ...)
A macro version of the above. A macro version of the above.

187
collects/handin-server/sandbox.ss
View File

@ -11,8 +11,10 @@
sandbox-path-permissions sandbox-path-permissions
sandbox-input sandbox-input
sandbox-output sandbox-output
sandbox-eval-limits
get-output get-output
get-uncovered-expressions get-uncovered-expressions
set-eval-limits
make-evaluator make-evaluator
call-with-limits call-with-limits
with-limits) with-limits)
@ -30,7 +32,7 @@
(define sandbox-input (make-parameter #f)) (define sandbox-input (make-parameter #f))
(define sandbox-output (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)) (define coverage-enabled (make-parameter #f))
@ -264,99 +266,104 @@
(define current-eventspace (mz/mr (make-parameter #f) current-eventspace)) (define current-eventspace (mz/mr (make-parameter #f) current-eventspace))
(define make-eventspace (mz/mr void make-eventspace)) (define make-eventspace (mz/mr void make-eventspace))
(define run-in-bg (mz/mr thread queue-callback)) (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-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) (define (make-evaluator language teachpacks input-program)
(let ([coverage-enabled (coverage-enabled)] (define coverage? (coverage-enabled))
[uncovered-expressions #f] (define uncovered-expressions #f)
[input-ch (make-channel)] (define input-ch (make-channel))
[result-ch (make-channel)] (define result-ch (make-channel))
[output #f]) (define output #f)
(parameterize (define limits (sandbox-eval-limits))
([current-namespace (make-evaluation-namespace)] (define (user-process)
[current-inspector (make-inspector)] ;; First read program and evaluate it as a module:
[current-library-collection-paths (with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
(filter directory-exists? (evaluate-program
(append (sandbox-override-collection-paths) language teachpacks input-program
(current-library-collection-paths)))] (and coverage? (lambda (exprs) (set! uncovered-expressions exprs))))
[exit-handler (lambda x (error 'exit "user code cannot exit"))] (channel-put result-ch 'ok))
[current-input-port ;; Now wait for interaction expressions:
(let ([inp (sandbox-input)]) (if inp (input->port inp) null-input))] (let loop ()
[current-output-port (let ([expr (channel-get input-ch)])
(let ([out (sandbox-output)]) (unless (eof-object? expr)
(cond [(not out) (open-output-nowhere)] (with-handlers ([void (lambda (exn)
[(output-port? out) (set! output out) out] (channel-put result-ch (cons 'exn exn)))])
[(eq? out 'pipe) (let* ([sec (and limits (car limits))]
(let-values ([(i o) (make-pipe)]) (set! output i) o)] [mb (and limits (cadr limits))]
[(memq out '(bytes string)) [run (if (or sec mb)
(let-values (lambda () (with-limits sec mb (eval expr)))
([(open get) (lambda () (eval expr)))])
(if (eq? out 'bytes) (channel-put result-ch
(values open-output-bytes get-output-bytes) (cons 'vals (call-with-values run list)))))
(values open-output-string get-output-string))]) (loop))))
(let ([o (open)]) (let loop ()
(set! output (lambda () (channel-put result-ch '(exn . nothing-more-to-evaluate))
(let ([o1 o]) (loop)))
(set! o (open)) (define (user-eval expr)
(current-output-port o) (channel-put input-ch expr)
(get-output-bytes o1)))) (let ([r (channel-get result-ch)])
o))] (if (eq? (car r) 'exn) (raise (cdr r)) (apply values (cdr r)))))
[else (error 'make-evaluator "bad output: ~e" out)]))] (define (evaluator expr)
[sandbox-path-permissions (cond [(eq? expr get-output)
(append (sandbox-path-permissions) (if (procedure? output) (user-eval `(,output)) output)]
(get-lib-permissions (sandbox-override-collection-paths)) [(eq? expr get-uncovered-expressions)
(require-perms language teachpacks))] uncovered-expressions]
[current-security-guard (sandbox-security-guard)]) [(eq? expr set-eval-limits)
;; Note the above definition of `current-eventspace': in MzScheme, it (lambda args (set! limits args))]
;; is a parameter that is not used at all. Also note that creating an [else (user-eval expr)]))
;; eventspace starts a thread that will eventually run the callback (parameterize
;; code (which evaluates the program in `run-in-bg') -- so this ([current-namespace (make-evaluation-namespace)]
;; parameterization must be nested in the above, or it will not use the [current-inspector (make-inspector)]
;; new namespace. [current-library-collection-paths
(parameterize ([current-eventspace (make-eventspace)]) (filter directory-exists?
(run-in-bg (append (sandbox-override-collection-paths)
(lambda () (current-library-collection-paths)))]
;; First read program and evaluate it as a module: [exit-handler (lambda x (error 'exit "user code cannot exit"))]
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) [current-input-port
(evaluate-program (let ([inp (sandbox-input)]) (if inp (input->port inp) null-input))]
language teachpacks input-program [current-output-port
(and coverage-enabled (let ([out (sandbox-output)])
(lambda (exprs) (set! uncovered-expressions exprs)))) (cond [(not out) (open-output-nowhere)]
(channel-put result-ch 'ok)) [(output-port? out) (set! output out) out]
;; Now wait for interaction expressions: [(eq? out 'pipe)
(let loop () (let-values ([(i o) (make-pipe)]) (set! output i) o)]
(let ([expr (channel-get input-ch)]) [(memq out '(bytes string))
(unless (eof-object? expr) (let-values
(with-handlers ([void (lambda (exn) ([(open get)
(channel-put result-ch (if (eq? out 'bytes)
(cons 'exn exn)))]) (values open-output-bytes get-output-bytes)
(channel-put result-ch (values open-output-string get-output-string))])
(cons 'vals (call-with-values (let ([o (open)])
(lambda () (eval expr)) (set! output (lambda ()
list)))) (let ([o1 o])
(loop)))) (set! o (open))
(let loop () (current-output-port o)
(channel-put result-ch '(exn . no-more-to-evaluate)) (get-output-bytes o1))))
(loop)))) o))]
(let ([r (channel-get result-ch)]) [else (error 'make-evaluator "bad output: ~e" out)]))]
(define (eval-in-user-context expr) [sandbox-path-permissions
(channel-put input-ch expr) (append (sandbox-path-permissions)
(let ([r (channel-get result-ch)]) (get-lib-permissions (sandbox-override-collection-paths))
(if (eq? (car r) 'exn) (raise (cdr r)) (apply values (cdr r))))) (require-perms language teachpacks))]
(if (eq? r 'ok) [current-security-guard (sandbox-security-guard)])
;; Initial program executed ok, so return an evaluator: ;; Note the above definition of `current-eventspace': in MzScheme, it is
(lambda (expr) ;; a parameter that is not used at all. Also note that creating an
(cond [(eq? expr get-uncovered-expressions) ;; eventspace starts a thread that will eventually run the callback code
uncovered-expressions] ;; (which evaluates the program in `run-in-bg') -- so this
[(eq? expr get-output) ;; parameterization must be nested in the above, or it will not use the
(if (procedure? output) ;; new namespace.
(eval-in-user-context `(,output)) (parameterize ([current-eventspace (make-eventspace)])
output)] (run-in-bg user-process)
[else (eval-in-user-context expr)])) (let ([r (channel-get result-ch)])
;; Program didn't execute: (if (eq? r 'ok)
(raise r))))))) ;; Initial program executed ok, so return an evaluator:
evaluator
;; Program didn't execute:
(raise r))))))
;; Resources ---------------------------------------------------------------- ;; Resources ----------------------------------------------------------------