new sandbox in mzlib
svn: r5873
This commit is contained in:
Eli Barzilay
parent
239e56f93d
commit
433c9a57ec
|
|
@ -493,7 +493,7 @@
|
|||
markup-prefix prefix-re))))
|
||||
(when create-text? (make-directory "grading") (write-text))
|
||||
(when value-printer (current-value-printer value-printer))
|
||||
(when coverage? (coverage-enabled #t))
|
||||
(when coverage? (sandbox-coverage-enabled #t))
|
||||
(set-run-status "checking submission")
|
||||
(cond
|
||||
[(not eval?) (let () body ...)]
|
||||
|
|
|
|||
|
|
@ -605,8 +605,12 @@ They are provided in a few layers, each layer provides new
|
|||
functionality in addition to the lower one. These modules are (in
|
||||
order):
|
||||
|
||||
* sandbox.ss -- basic sandbox evaluation utilities, can be used
|
||||
independently from the handin-server.
|
||||
* mzlib/sandbox.ss -- basic sandbox evaluation utilities. This is in
|
||||
MzLib since it can be used independently. (See the MzLib manual for
|
||||
details.)
|
||||
|
||||
* sandbox.ss -- a wrapper that configures MzLib's sandbox for the
|
||||
handin server.
|
||||
|
||||
* utils.ss -- additional utilities for dealing with handin
|
||||
submissions, as well as a few helpers for testing code.
|
||||
|
|
@ -621,195 +625,8 @@ The following sections describe each of these modules.
|
|||
_sandbox.ss_
|
||||
------------
|
||||
|
||||
The main function that is implemented in this module is
|
||||
`make-evaluator'. Most of the functionality that is provided is used
|
||||
by this function.
|
||||
|
||||
> mred?
|
||||
A boolean that is bound to `#t' if we're currently running in MrEd,
|
||||
`#f' if in plain MzScheme. The idea is that you can use this module
|
||||
both from MzScheme or, if needed, from MrEd. (Higher levels
|
||||
("utils.ss" and "checker.ss"), need to be used with MrEd.)
|
||||
|
||||
> coverage-enabled
|
||||
A boolean parameter that controls whether coverage testing is
|
||||
enabled in `make-evaluator'-created functions. If it set to true,
|
||||
the "handin-server/private/coverage.ss" module will be used to
|
||||
detect uncovered expressions. This information is collected after
|
||||
the input port has been evaluated, so it is not affected by testing
|
||||
code that is not part of the submission. To retrieve the collected
|
||||
information, apply the evaluation function on the special
|
||||
`get-uncovered-expressions' value below. The resulting value is a
|
||||
list of uncovered expressions, with at most one per position+span
|
||||
(which means that the contents may be unreliable, but the position
|
||||
is). The default is `#f'.
|
||||
|
||||
> 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
|
||||
list is a thunk that creates the namespace, and the rest are require
|
||||
specs for modules that are to be attached to the created namespace.
|
||||
The default is `make-namespace' and `(lib "posn.ss" "lang")' if
|
||||
running in MzScheme, or `make-namespace-with-mred' and
|
||||
`(lib "cache-image-snip.ss" "mrlib")' as well as the posn library.
|
||||
(The module specs are needed for sharing module instantiations, for
|
||||
example, without the above, posn values in testing code will be a
|
||||
different type from posn values in tested code.)
|
||||
|
||||
> sandbox-reader
|
||||
A parameter that holds a function that reads all expressions from
|
||||
the current-input-port. It is used to read the submission source.
|
||||
It must return a list of syntax objects, and it must use the symbol
|
||||
`program' as the input source (that is, something like a loop that
|
||||
consumes the input using `(read-syntax 'program)'). The default
|
||||
reader is using a plain `read-syntax' -- it does so while setting
|
||||
`read-case-sensitive' to `#t', and `read-decimal-as-inexact' to `#f'
|
||||
(both are sensible choices for testing code).
|
||||
|
||||
> sandbox-override-collection-paths
|
||||
A parameter that holds a list of collection directories. A
|
||||
submission evaluator that is created by `make-evaluator' will put
|
||||
these directories (ones tat actually exist) in front of the
|
||||
collections in `current-library-collection-paths' -- so you can put
|
||||
collection overrides there. The default is an `overridden-collects'
|
||||
directory in the handin-server collection, which comes with a few
|
||||
common overrides for teachpacks that use the GUI.
|
||||
|
||||
> sandbox-security-guard
|
||||
A parameter that holds a security guard that is used by all
|
||||
evaluations that happen in a `make-evaluator' function. The default
|
||||
value is a security guard that forbids all I/O, except for things in
|
||||
`sandbox-path-permissions' (see below).
|
||||
|
||||
> sandbox-path-permissions
|
||||
This parameter configures the behavior of the default sandbox
|
||||
security guard by listing path and access modes that are allowed.
|
||||
The contents of this parameter is a list of specs, each one is a
|
||||
list of an access mode (a symbol) and a path spec that is granted
|
||||
this access. The access mode symbol is one of: 'execute, 'write,
|
||||
'read, or 'exists, where each of these implies that modes that
|
||||
follow are also permitted (eg, 'read allows reading or checking for
|
||||
existence). The path spec is either a path as a byte string (must
|
||||
be resolved and simplified) that will match exactly that path, or a
|
||||
byte-regexp that applies for all matching paths. The default value
|
||||
is a list of 'read permissions for the library collection paths.
|
||||
Note that when an evaluator is created by `make-evaluator', the list
|
||||
is augmented with permissions for accessing non-`lib' teachpack
|
||||
requires and language module.
|
||||
|
||||
> sandbox-input
|
||||
A parameter that specifies the input for evaluations that happen in
|
||||
a `make-evaluator' function. It defaults to `#f', which makes such
|
||||
functions work in a context where no input is available. It can be
|
||||
set to:
|
||||
* an input port, which will be used as is;
|
||||
* a string or a byte string that will be used as the complete input;
|
||||
* a path that names a file holding the input.
|
||||
|
||||
> sandbox-output
|
||||
A parameter that specifies the output for evaluations that happen in
|
||||
a `make-evaluator' function. It defaults to `#f', which simply
|
||||
discards all such output. It can also be set to:
|
||||
* an output port, which will be used as is;
|
||||
* the symbol 'bytes, which will make `get-output' (see below) return
|
||||
the complete output as a byte string;
|
||||
* the symbol 'string, similar to the above, but uses a string;
|
||||
* the symbol 'pipe, which will make it use a pipe for output, and
|
||||
`get-output' returns the input end of the pipe.
|
||||
(Note that error output is *not* redirected.)
|
||||
|
||||
> 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.
|
||||
|
||||
This function Creates an evaluator function for evaluating
|
||||
expressions in the designated `language', after loading teachpacks
|
||||
that are specified in `teachpack-paths', and after evaluating the
|
||||
code in the `input-program'.
|
||||
|
||||
The `input-program' holds the input program in the same way as the
|
||||
`sandbox-input' parameter (but it cannot be `#f'). The contents of
|
||||
this input is read using the `sandbox-reader', with line-counting
|
||||
enabled.
|
||||
|
||||
The `language' can be:
|
||||
* a symbol indicating a built-in language (currently, only
|
||||
'mzscheme), or a teaching language -- one of 'beginner,
|
||||
'beginner-abbr, 'intermediate, 'intermediate-lambda, or 'advanced.
|
||||
* a list that begins with a 'lib, 'file, or 'planet symbol, which
|
||||
stands for the language defined by this (quoted) module
|
||||
specification, or a string specifying a relative module filename
|
||||
directly.
|
||||
* a list that begins with a 'begin symbol means that the code will
|
||||
not be evaluated in a module context at all, it will simply be
|
||||
evaluated in a new namespace, after evaluating this list.
|
||||
|
||||
The `teachpack-paths' list specifies additional code to load, can be
|
||||
one of:
|
||||
* paths to teachpacks to load into the module.
|
||||
* a list that begins with a 'begin symbol is arbitrary code that is
|
||||
prefixed into the submitted program.
|
||||
|
||||
The actual evaluation of expressions (both the program and later
|
||||
evaluations) happens under the `sandbox-security-guard'
|
||||
restrictions, and if MrEd is used -- in a newly created eventspace.
|
||||
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. (Note: memory limits 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.
|
||||
This is just a wrapper around the sandbox engine from MzLib. It
|
||||
configures it for use with the handin server.
|
||||
|
||||
|
||||
_utils.ss_
|
||||
|
|
|
|||
|
|
@ -1,396 +1,16 @@
|
|||
(module sandbox mzscheme
|
||||
(require (lib "string.ss") (lib "list.ss") (lib "port.ss")
|
||||
(lib "moddep.ss" "syntax"))
|
||||
(require (lib "sandbox.ss"))
|
||||
(provide (all-from (lib "sandbox.ss")))
|
||||
|
||||
(provide mred?
|
||||
coverage-enabled
|
||||
namespace-specs
|
||||
sandbox-reader
|
||||
sandbox-override-collection-paths
|
||||
sandbox-security-guard
|
||||
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)
|
||||
(sandbox-namespace-specs
|
||||
(let ([specs (sandbox-namespace-specs)])
|
||||
`(,(car specs)
|
||||
,@(cdr specs)
|
||||
(lib "posn.ss" "lang")
|
||||
,@(if mred? '((lib "cache-image-snip.ss" "mrlib")) '()))))
|
||||
|
||||
(define mred?
|
||||
(with-handlers ([void (lambda (_) #f)])
|
||||
(dynamic-require '#%mred-kernel #f)
|
||||
#t))
|
||||
(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding
|
||||
(syntax-rules ()
|
||||
[(mz/mr mzval mrsym)
|
||||
(if mred? (dynamic-require '(lib "mred.ss" "mred") 'mrsym) mzval)]))
|
||||
|
||||
;; Configuration ------------------------------------------------------------
|
||||
|
||||
(define sandbox-input (make-parameter #f))
|
||||
(define sandbox-output (make-parameter #f))
|
||||
(define sandbox-eval-limits (make-parameter '(30 10))) ; 30sec, 10mb
|
||||
|
||||
(define coverage-enabled (make-parameter #f))
|
||||
|
||||
(define namespace-specs
|
||||
(make-parameter
|
||||
(let ([mods '((lib "posn.ss" "lang"))]
|
||||
[mred-mods '((lib "cache-image-snip.ss" "mrlib"))])
|
||||
`(,(mz/mr make-namespace make-namespace-with-mred)
|
||||
,@mods ,@(if mred? mred-mods '())))))
|
||||
|
||||
(define (default-sandbox-reader)
|
||||
(parameterize ([read-case-sensitive #t] [read-decimal-as-inexact #f])
|
||||
(let loop ([l '()])
|
||||
(let ([expr (read-syntax 'program)])
|
||||
(if (eof-object? expr)
|
||||
(reverse! l)
|
||||
(loop (cons expr l)))))))
|
||||
|
||||
(define sandbox-reader (make-parameter default-sandbox-reader))
|
||||
|
||||
(define sandbox-override-collection-paths
|
||||
(make-parameter (list (build-path (collection-path "handin-server")
|
||||
"overridden-collects"))))
|
||||
|
||||
;; Security Guard -----------------------------------------------------------
|
||||
|
||||
(define sep (bytes-ref (path->bytes (simplify-path "/")) 0)) ; '\' on windows
|
||||
|
||||
(define (simplify-path* path)
|
||||
(simplify-path
|
||||
(expand-path
|
||||
(path->complete-path (if (bytes? path) (bytes->path path) path)))))
|
||||
|
||||
(define permission-order '(execute write read exists))
|
||||
(define (perm<=? p1 p2)
|
||||
(memq p1 (memq p2 permission-order)))
|
||||
|
||||
(define dir-path->bytes-re
|
||||
(let* ([sep-re (regexp-quote (bytes sep))]
|
||||
[last-sep (byte-regexp (bytes-append sep-re #"?$"))])
|
||||
(lambda (path)
|
||||
(byte-regexp (regexp-replace last-sep
|
||||
(path->bytes (simplify-path* path))
|
||||
(bytes-append #"(?:$|" sep-re #")"))))))
|
||||
|
||||
(define (get-lib-permissions libs)
|
||||
(let* ([sep-re (regexp-quote (bytes sep))]
|
||||
[last-sep (byte-regexp (bytes-append sep-re #"?$"))])
|
||||
(map (lambda (p) (list 'read (dir-path->bytes-re p))) libs)))
|
||||
|
||||
(define sandbox-path-permissions
|
||||
(make-parameter (get-lib-permissions (current-library-collection-paths))))
|
||||
|
||||
(define (path-ok? bpath ok)
|
||||
(cond [(bytes? ok) (equal? bpath ok)]
|
||||
[(byte-regexp? ok) (regexp-match? ok bpath)]
|
||||
[else (error 'path-ok? "bad path spec: ~e" ok)]))
|
||||
|
||||
(define default-sandbox-guard
|
||||
(let ([orig-security (current-security-guard)])
|
||||
(make-security-guard
|
||||
orig-security
|
||||
(lambda (what path modes)
|
||||
(when path
|
||||
(let ([needed (let loop ([order permission-order])
|
||||
(cond [(null? order)
|
||||
(error 'default-sandbox-guard
|
||||
"unknown access modes: ~e" modes)]
|
||||
[(memq (car order) modes) (car order)]
|
||||
[else (loop (cdr order))]))]
|
||||
[bpath (parameterize ([current-security-guard orig-security])
|
||||
(path->bytes (simplify-path* path)))])
|
||||
(unless (ormap (lambda (perm)
|
||||
(and (perm<=? needed (car perm))
|
||||
(path-ok? bpath (cadr perm))))
|
||||
(sandbox-path-permissions))
|
||||
(error what "file access denied ~a" (cons path modes))))))
|
||||
(lambda (what . xs) (error what "network access denied: ~e" xs)))))
|
||||
|
||||
(define sandbox-security-guard (make-parameter default-sandbox-guard))
|
||||
|
||||
;; computes permissions that are needed for require specs (`read' for all
|
||||
;; files and "compiled" subdirs, `exists' for the base-dir)
|
||||
(define (module-specs->path-permissions mods)
|
||||
(define paths (module-specs->non-lib-paths mods))
|
||||
(define bases
|
||||
(let loop ([paths paths] [bases '()])
|
||||
(if (null? paths)
|
||||
(reverse! bases)
|
||||
(let-values ([(base name dir?) (split-path (car paths))])
|
||||
(let ([base (simplify-path* base)])
|
||||
(loop (cdr paths)
|
||||
(if (member base bases) bases (cons base bases))))))))
|
||||
(append (map (lambda (p) (list 'read (path->bytes p))) paths)
|
||||
(map (lambda (b)
|
||||
(list 'read (dir-path->bytes-re (build-path b "compiled"))))
|
||||
bases)
|
||||
(map (lambda (b)
|
||||
(list 'exists (path->bytes (path->directory-path b))))
|
||||
bases)))
|
||||
|
||||
;; takes a module-spec list and returns all module paths that are needed
|
||||
;; ==> ignores (lib ...) modules
|
||||
(define (module-specs->non-lib-paths mods)
|
||||
(define (lib? x)
|
||||
(if (module-path-index? x)
|
||||
(let-values ([(m base) (module-path-index-split x)]) (lib? m))
|
||||
(and (pair? x) (eq? 'lib (car x)))))
|
||||
(let loop ([todo (filter values
|
||||
(map (lambda (mod)
|
||||
(and (not (lib? mod))
|
||||
(simplify-path*
|
||||
(resolve-module-path mod #f))))
|
||||
mods))]
|
||||
[r '()])
|
||||
(cond
|
||||
[(null? todo) r]
|
||||
[(member (car todo) r) (loop (cdr todo) r)]
|
||||
[else
|
||||
(let ([path (car todo)])
|
||||
(loop (map (lambda (i)
|
||||
(simplify-path* (resolve-module-path-index i path)))
|
||||
(filter (lambda (i)
|
||||
(and (module-path-index? i) (not (lib? i))))
|
||||
(apply append
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(module-compiled-imports
|
||||
(get-module-code (car todo))))
|
||||
list))))
|
||||
(cons path r)))])))
|
||||
|
||||
;; Execution ----------------------------------------------------------------
|
||||
|
||||
(define (make-evaluation-namespace)
|
||||
(let* ([specs (namespace-specs)]
|
||||
[new-ns ((car specs))]
|
||||
[orig-ns (current-namespace)]
|
||||
[mods (cdr specs)]
|
||||
[resolve (current-module-name-resolver)])
|
||||
(for-each (lambda (mod) (dynamic-require mod #f)) mods)
|
||||
(let ([modsyms (map (lambda (mod) (resolve mod #f #f)) mods)])
|
||||
(parameterize ([current-namespace new-ns])
|
||||
(for-each (lambda (ms) (namespace-attach-module orig-ns ms))
|
||||
modsyms)))
|
||||
new-ns))
|
||||
|
||||
(define (input->port inp)
|
||||
(cond [(input-port? inp) inp]
|
||||
[(string? inp) (open-input-string inp)]
|
||||
[(bytes? inp) (open-input-bytes inp)]
|
||||
[(path? inp) (open-input-file inp)]
|
||||
[else (error 'input->port "bad input: ~e" inp)]))
|
||||
|
||||
(define (read-code inp)
|
||||
(parameterize ([current-input-port (input->port inp)])
|
||||
(port-count-lines! (current-input-port))
|
||||
((sandbox-reader))))
|
||||
|
||||
(define (require-perms language teachpacks)
|
||||
(let* ([requires
|
||||
(if (and (pair? teachpacks) (eq? 'begin (car teachpacks)))
|
||||
(apply append
|
||||
(map cdr
|
||||
(filter
|
||||
(lambda (x)
|
||||
(let ([fst (and (pair? x) (car x))])
|
||||
(eq? 'require
|
||||
(if (syntax? fst) (syntax-e fst) fst))))
|
||||
(cdr teachpacks))))
|
||||
teachpacks)]
|
||||
[requires
|
||||
(if (or (and (pair? language) (memq (car language) '(file planet)))
|
||||
(string? language))
|
||||
(cons language requires)
|
||||
requires)])
|
||||
(module-specs->path-permissions requires)))
|
||||
|
||||
(define (evaluate-program language teachpacks input-program uncovered!)
|
||||
(let* ([body (read-code input-program)]
|
||||
[body (append (if (and (pair? teachpacks)
|
||||
(eq? 'begin (car teachpacks)))
|
||||
(cdr teachpacks)
|
||||
(map (lambda (tp)
|
||||
`(,#'require ,(if (pair? tp) tp `(file ,tp))))
|
||||
teachpacks))
|
||||
body)]
|
||||
[body (cond [(and (symbol? language)
|
||||
(memq language '(beginner
|
||||
beginner-abbr
|
||||
intermediate
|
||||
intermediate-lambda
|
||||
advanced)))
|
||||
`(module m
|
||||
(lib ,(case language
|
||||
[(beginner) "htdp-beginner.ss"]
|
||||
[(beginner-abbr) "htdp-beginner-abbr.ss"]
|
||||
[(intermediate) "htdp-intermediate.ss"]
|
||||
[(intermediate-lambda)
|
||||
"htdp-intermediate-lambda.ss"]
|
||||
[(advanced) "htdp-advanced.ss"])
|
||||
"lang")
|
||||
,@body)]
|
||||
[(or (and (pair? language) (eq? 'lib (car language)))
|
||||
(symbol? language))
|
||||
`(module m ,language ,@body)]
|
||||
[(or (and (pair? language)
|
||||
(memq (car language) '(file planet)))
|
||||
(string? language))
|
||||
`(module m ,language ,@body)]
|
||||
[(and (pair? language)
|
||||
(eq? 'begin (car language)))
|
||||
`(begin ,language ,@body)]
|
||||
[else (error 'make-evaluator
|
||||
"Bad language specification: ~e"
|
||||
language)])]
|
||||
[ns (current-namespace)])
|
||||
(when uncovered!
|
||||
(eval '(require (lib "coverage.ss" "handin-server" "private"))))
|
||||
(eval body)
|
||||
(when (and (pair? body) (eq? 'module (car body))
|
||||
(pair? (cdr body)) (symbol? (cadr body)))
|
||||
(let ([mod (cadr body)])
|
||||
(eval `(require ,mod))
|
||||
(current-namespace (module->namespace mod))))
|
||||
(when uncovered!
|
||||
(uncovered! (filter (lambda (x) (eq? 'program (syntax-source x)))
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval '(get-uncovered-expressions))))))))
|
||||
|
||||
(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 (set-eval-limits eval . args) (apply (eval set-eval-limits) args))
|
||||
|
||||
(define (make-evaluator language teachpacks input-program)
|
||||
(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 ----------------------------------------------------------------
|
||||
|
||||
(define (call-with-limits sec mb thunk)
|
||||
(let ([cust (make-custodian)]
|
||||
[ch (make-channel)])
|
||||
(when mb (custodian-limit-memory cust (* mb 1024 1024) cust))
|
||||
(let* ([work (parameterize ([current-custodian cust])
|
||||
(thread (lambda ()
|
||||
(channel-put ch
|
||||
(with-handlers ([void (lambda (e)
|
||||
(list raise e))])
|
||||
(call-with-values thunk
|
||||
(lambda vs (cons values vs))))))))]
|
||||
[watch (thread (lambda ()
|
||||
(channel-put ch
|
||||
(if (sync/timeout sec work) 'memory 'time))))]
|
||||
[r (channel-get ch)])
|
||||
(custodian-shutdown-all cust)
|
||||
(kill-thread watch)
|
||||
(if (list? r)
|
||||
(apply (car r) (cdr r))
|
||||
(error 'with-limit "out of ~a" r)))))
|
||||
|
||||
(define-syntax with-limits
|
||||
(syntax-rules ()
|
||||
[(with-limits sec mb body ...)
|
||||
(call-with-limits sec mb (lambda () body ...))]))
|
||||
(sandbox-override-collection-paths
|
||||
(cons (build-path (collection-path "handin-server") "overridden-collects")
|
||||
(sandbox-override-collection-paths)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
;; Use the stacktrace interface from errortrace to find uncovered expressions.
|
||||
(module coverage mzscheme
|
||||
;; This file is is used in the context of sandboxed code, it uses the
|
||||
;; stacktrace interface from errortrace to find uncovered expressions.
|
||||
(module sandbox-coverage mzscheme
|
||||
(require (lib "stacktrace.ss" "errortrace") (lib "unit.ss") (lib "list.ss"))
|
||||
|
||||
;; Test coverage run-time support
|
||||
532
collects/mzlib/sandbox.ss
Normal file
532
collects/mzlib/sandbox.ss
Normal file
|
|
@ -0,0 +1,532 @@
|
|||
(module sandbox mzscheme
|
||||
(require (lib "string.ss") (lib "list.ss") (lib "port.ss")
|
||||
(lib "moddep.ss" "syntax"))
|
||||
|
||||
(provide mred?
|
||||
sandbox-init-hook
|
||||
sandbox-reader
|
||||
sandbox-input
|
||||
sandbox-output
|
||||
sandbox-error-output
|
||||
sandbox-coverage-enabled
|
||||
sandbox-namespace-specs
|
||||
sandbox-override-collection-paths
|
||||
sandbox-security-guard
|
||||
sandbox-path-permissions
|
||||
sandbox-network-guard
|
||||
sandbox-eval-limits
|
||||
kill-evaluator
|
||||
get-output
|
||||
get-error-output
|
||||
get-uncovered-expressions
|
||||
set-eval-limits
|
||||
make-evaluator
|
||||
call-with-limits
|
||||
with-limits
|
||||
exn:fail:resource?
|
||||
exn:fail:resource-resource)
|
||||
|
||||
(define mred?
|
||||
(with-handlers ([void (lambda (_) #f)])
|
||||
(dynamic-require '#%mred-kernel #f)
|
||||
#t))
|
||||
(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding
|
||||
(syntax-rules ()
|
||||
[(mz/mr mzval mrsym)
|
||||
(if mred? (dynamic-require '(lib "mred.ss" "mred") 'mrsym) mzval)]))
|
||||
|
||||
;; Configuration ------------------------------------------------------------
|
||||
|
||||
(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-eval-limits (make-parameter '(30 10))) ; 30sec, 10mb
|
||||
(define sandbox-coverage-enabled (make-parameter #f))
|
||||
|
||||
(define sandbox-namespace-specs
|
||||
(make-parameter `(,(mz/mr make-namespace make-namespace-with-mred)
|
||||
#| no modules here by default |#)))
|
||||
|
||||
(define (default-sandbox-reader source)
|
||||
(let loop ([l '()])
|
||||
(let ([expr (read-syntax source)])
|
||||
(if (eof-object? expr)
|
||||
(reverse! l)
|
||||
(loop (cons expr l))))))
|
||||
|
||||
(define sandbox-reader (make-parameter default-sandbox-reader))
|
||||
|
||||
(define sandbox-override-collection-paths (make-parameter '()))
|
||||
|
||||
(define teaching-langs
|
||||
'(beginner beginner-abbr intermediate intermediate-lambda advanced))
|
||||
|
||||
;; Security Guard -----------------------------------------------------------
|
||||
|
||||
(define sep (bytes-ref (path->bytes (simplify-path "/")) 0)) ; '\' on windows
|
||||
|
||||
(define (simplify-path* path)
|
||||
(simplify-path (expand-path (path->complete-path
|
||||
(cond [(bytes? path) (bytes->path path)]
|
||||
[(string? path) (string->path path)]
|
||||
[else path])))))
|
||||
|
||||
(define permission-order '(execute write delete read exists))
|
||||
(define (perm<=? p1 p2)
|
||||
(memq p1 (memq p2 permission-order)))
|
||||
|
||||
;; gets a path (can be bytes/string), returns a regexp for that path that
|
||||
;; matches also subdirs (if it's a directory)
|
||||
(define path->bregexp
|
||||
(let* ([sep-re (regexp-quote (bytes sep))]
|
||||
[last-sep (byte-regexp (bytes-append sep-re #"?$"))]
|
||||
[suffix-re (bytes-append #"(?:$|" sep-re #")")])
|
||||
(lambda (path)
|
||||
(if (byte-regexp? path)
|
||||
path
|
||||
(let* ([path (path->bytes (simplify-path* path))]
|
||||
[path (regexp-quote (regexp-replace last-sep path #""))])
|
||||
(byte-regexp (bytes-append #"^" path suffix-re)))))))
|
||||
|
||||
(define sandbox-path-permissions
|
||||
(make-parameter '()
|
||||
(lambda (new)
|
||||
(map (lambda (perm) (cons (car perm) (map path->bregexp (cdr perm))))
|
||||
new))))
|
||||
|
||||
(define sandbox-network-guard
|
||||
(make-parameter (lambda (what . xs)
|
||||
(error what "network access denied: ~e" xs))))
|
||||
|
||||
(define default-sandbox-guard
|
||||
(let ([orig-security (current-security-guard)])
|
||||
(make-security-guard
|
||||
orig-security
|
||||
(lambda (what path modes)
|
||||
(when path
|
||||
(let ([needed (let loop ([order permission-order])
|
||||
(cond [(null? order)
|
||||
(error 'default-sandbox-guard
|
||||
"unknown access modes: ~e" modes)]
|
||||
[(memq (car order) modes) (car order)]
|
||||
[else (loop (cdr order))]))]
|
||||
[bpath (parameterize ([current-security-guard orig-security])
|
||||
(path->bytes (simplify-path* path)))])
|
||||
(unless (ormap (lambda (perm)
|
||||
(and (perm<=? needed (car perm))
|
||||
(regexp-match (cadr perm) bpath)))
|
||||
(sandbox-path-permissions))
|
||||
(error what "file access denied ~a" (cons path modes))))))
|
||||
(lambda args (apply (sandbox-network-guard) args)))))
|
||||
|
||||
(define sandbox-security-guard (make-parameter default-sandbox-guard))
|
||||
|
||||
;; computes permissions that are needed for require specs (`read' for all
|
||||
;; files and "compiled" subdirs, `exists' for the base-dir)
|
||||
(define (module-specs->path-permissions mods)
|
||||
(define paths (module-specs->non-lib-paths mods))
|
||||
(define bases
|
||||
(let loop ([paths paths] [bases '()])
|
||||
(if (null? paths)
|
||||
(reverse! bases)
|
||||
(let-values ([(base name dir?) (split-path (car paths))])
|
||||
(let ([base (simplify-path* base)])
|
||||
(loop (cdr paths)
|
||||
(if (member base bases) bases (cons base bases))))))))
|
||||
(append (map (lambda (p) `(read ,(path->bytes p))) paths)
|
||||
(map (lambda (b) `(read ,(build-path b "compiled"))) bases)
|
||||
(map (lambda (b) `(exists ,b)) bases)))
|
||||
|
||||
;; takes a module-spec list and returns all module paths that are needed
|
||||
;; ==> ignores (lib ...) modules
|
||||
(define (module-specs->non-lib-paths mods)
|
||||
(define (lib? x)
|
||||
(if (module-path-index? x)
|
||||
(let-values ([(m base) (module-path-index-split x)]) (lib? m))
|
||||
(and (pair? x) (eq? 'lib (car x)))))
|
||||
(let loop ([todo (filter values
|
||||
(map (lambda (mod)
|
||||
(and (not (lib? mod))
|
||||
(simplify-path*
|
||||
(resolve-module-path mod #f))))
|
||||
mods))]
|
||||
[r '()])
|
||||
(cond
|
||||
[(null? todo) r]
|
||||
[(member (car todo) r) (loop (cdr todo) r)]
|
||||
[else
|
||||
(let ([path (car todo)])
|
||||
(loop (map (lambda (i)
|
||||
(simplify-path* (resolve-module-path-index i path)))
|
||||
(filter (lambda (i)
|
||||
(and (module-path-index? i) (not (lib? i))))
|
||||
(apply append
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(module-compiled-imports
|
||||
(get-module-code (car todo))))
|
||||
list))))
|
||||
(cons path r)))])))
|
||||
|
||||
;; Resources ----------------------------------------------------------------
|
||||
|
||||
(define-struct (exn:fail:resource exn:fail) (resource))
|
||||
|
||||
(define (call-with-limits sec mb thunk)
|
||||
(let ([cust (make-custodian)]
|
||||
[ch (make-channel)]
|
||||
;; use this to copy parameter changes from the sub-thread
|
||||
[p current-preserved-thread-cell-values])
|
||||
(when mb (custodian-limit-memory cust (* mb 1024 1024) cust))
|
||||
(let* ([work (parameterize ([current-custodian cust])
|
||||
(thread (lambda ()
|
||||
(channel-put ch
|
||||
(with-handlers ([void (lambda (e)
|
||||
(list (p) raise e))])
|
||||
(call-with-values thunk
|
||||
(lambda vs (list* (p) values vs))))))))]
|
||||
[watch (thread (lambda ()
|
||||
(channel-put ch
|
||||
(if (sync/timeout sec work) 'memory 'time))))]
|
||||
[r (channel-get ch)])
|
||||
(custodian-shutdown-all cust)
|
||||
(kill-thread watch)
|
||||
(if (list? r)
|
||||
;; apply parameter changes first
|
||||
(begin (p (car r)) (apply (cadr r) (cddr r)))
|
||||
(raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
|
||||
(current-continuation-marks)
|
||||
r))))))
|
||||
|
||||
(define-syntax with-limits
|
||||
(syntax-rules ()
|
||||
[(with-limits sec mb body ...)
|
||||
(call-with-limits sec mb (lambda () body ...))]))
|
||||
|
||||
;; Execution ----------------------------------------------------------------
|
||||
|
||||
(define (literal-identifier=? x y)
|
||||
(or (module-identifier=? x y)
|
||||
(eq? (if (syntax? x) (syntax-e x) x) (if (syntax? y) (syntax-e y) y))))
|
||||
|
||||
(define (make-evaluation-namespace)
|
||||
(let* ([specs (sandbox-namespace-specs)]
|
||||
[new-ns ((car specs))]
|
||||
[orig-ns (current-namespace)]
|
||||
[mods (cdr specs)]
|
||||
[resolve (current-module-name-resolver)])
|
||||
(for-each (lambda (mod) (dynamic-require mod #f)) mods)
|
||||
(let ([modsyms (map (lambda (mod) (resolve mod #f #f)) mods)])
|
||||
(parameterize ([current-namespace new-ns])
|
||||
(for-each (lambda (ms) (namespace-attach-module orig-ns ms))
|
||||
modsyms)))
|
||||
new-ns))
|
||||
|
||||
(define (require-perms language requires)
|
||||
(define (find-requires forms)
|
||||
(let loop ([forms (reverse forms)] [reqs '()])
|
||||
(if (null? forms)
|
||||
reqs
|
||||
(loop (cdr forms)
|
||||
(syntax-case* (car forms) (require) literal-identifier=?
|
||||
[(require specs ...)
|
||||
(append (syntax-object->datum #'(specs ...)) reqs)]
|
||||
[_else reqs])))))
|
||||
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
|
||||
(find-requires (cdr requires))
|
||||
requires)]
|
||||
[requires (cond [(string? language) (cons language requires)]
|
||||
[(not (pair? language)) requires]
|
||||
[(memq (car language) '(file planet))
|
||||
(cons language requires)]
|
||||
[(eq? (car language) 'begin)
|
||||
(append (find-requires (cdr language)) requires)]
|
||||
[else 'require-perms
|
||||
"bad language spec: ~e" language])])
|
||||
(module-specs->path-permissions requires)))
|
||||
|
||||
(define (input->port inp)
|
||||
;; returns #f when it can't create a port
|
||||
(cond [(input-port? inp) inp]
|
||||
[(string? inp) (open-input-string inp)]
|
||||
[(bytes? inp) (open-input-bytes inp)]
|
||||
[(path? inp) (open-input-file inp)]
|
||||
[else #f]))
|
||||
|
||||
;; Gets an input spec returns a list of syntaxes. The input can be a list of
|
||||
;; sexprs/syntaxes, or a list with a single input port spec
|
||||
;; (path/string/bytes) value.
|
||||
(define (input->code inps source n)
|
||||
(if (null? inps)
|
||||
'()
|
||||
(let ([p (input->port (car inps))])
|
||||
(cond [(and p (null? (cdr inps)))
|
||||
(port-count-lines! p)
|
||||
(parameterize ([current-input-port p])
|
||||
((sandbox-reader) source))]
|
||||
[p (error 'input->code "ambiguous inputs: ~e" inps)]
|
||||
[else (let loop ([inps inps] [n n] [r '()])
|
||||
(if (null? inps)
|
||||
(reverse! r)
|
||||
(loop (cdr inps) (and n (add1 n))
|
||||
;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc
|
||||
;; (starting from the `n' argument)
|
||||
(cons (datum->syntax-object
|
||||
#f (car inps)
|
||||
(list source n (and n 0) n (and n 1)))
|
||||
r))))]))))
|
||||
|
||||
(define ((init-for-language language))
|
||||
(cond [(eq? language 'r5rs)
|
||||
(read-case-sensitive #f)
|
||||
(read-square-bracket-as-paren #f)
|
||||
(read-curly-brace-as-paren #f)]
|
||||
[(memq language teaching-langs)
|
||||
(read-case-sensitive #t)
|
||||
(read-decimal-as-inexact #f)]))
|
||||
|
||||
;; Returns a single (module ...) or (begin ...) expression (a `begin' list
|
||||
;; will be evaluated one by one -- the language might not have a `begin').
|
||||
(define (build-program language requires input-program)
|
||||
(let* ([body (append (if (and (pair? requires) (eq? 'begin (car requires)))
|
||||
(cdr requires)
|
||||
(map (lambda (r) (list #'require r))
|
||||
requires))
|
||||
(input->code input-program 'program 1))]
|
||||
[use-lang (lambda (lang) `(module program ,lang . ,body))])
|
||||
(cond [(memq language teaching-langs)
|
||||
(use-lang `(lib ,(format "htdp-~a.ss" language) "lang"))]
|
||||
[(eq? language 'r5rs)
|
||||
(use-lang `(lib "lang.ss" "r5rs"))]
|
||||
[(or (and (pair? language) (memq (car language) '(lib file planet)))
|
||||
(symbol? language) (string? language))
|
||||
(use-lang language)]
|
||||
[(and (pair? language) (eq? 'begin (car language)))
|
||||
(append language body)]
|
||||
[else (error 'make-evaluator "bad language spec: ~e" language)])))
|
||||
|
||||
;; Like a toplevel (eval `(begin ,@exprs)), but the language that is used may
|
||||
;; not have a begin.
|
||||
(define (eval* exprs)
|
||||
(if (null? exprs)
|
||||
(void)
|
||||
(let ([deftag (default-continuation-prompt-tag)])
|
||||
(let loop ([expr (car exprs)] [exprs (cdr exprs)])
|
||||
(if (null? exprs)
|
||||
(eval expr)
|
||||
(begin
|
||||
(call-with-continuation-prompt
|
||||
(lambda () (eval expr))
|
||||
deftag
|
||||
(lambda (x) (abort-current-continuation deftag x)))
|
||||
(loop (car exprs) (cdr exprs))))))))
|
||||
|
||||
(define (evaluate-program program limits uncovered!)
|
||||
(when uncovered!
|
||||
(eval `(,#'require (lib "sandbox-coverage.ss" "mzlib" "private"))))
|
||||
;; the actual evaluation happens under specified limits, if given
|
||||
(let ([run (if (and (pair? program) (eq? 'begin (car program)))
|
||||
(lambda () (eval* (cdr program)))
|
||||
(lambda () (eval program)))]
|
||||
[sec (and limits (car limits))]
|
||||
[mb (and limits (cadr limits))])
|
||||
(if (or sec mb) (call-with-limits sec mb run) (run)))
|
||||
(let ([ns (syntax-case* program (module) literal-identifier=?
|
||||
[(module mod . body)
|
||||
(identifier? #'mod)
|
||||
(let ([mod #'mod])
|
||||
(eval `(,#'require ,mod))
|
||||
(module->namespace (syntax-e mod)))]
|
||||
[_else #f])])
|
||||
(when uncovered!
|
||||
(let ([get (let ([ns (current-namespace)])
|
||||
(lambda () (eval '(get-uncovered-expressions) ns)))])
|
||||
(uncovered! (list (get) get))))
|
||||
(when ns (current-namespace ns))))
|
||||
|
||||
(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 (kill-evaluator eval) (eval kill-evaluator))
|
||||
(define (get-output eval) (eval get-output))
|
||||
(define (get-error-output eval) (eval get-error-output))
|
||||
(define (get-uncovered-expressions eval . args)
|
||||
(apply (eval get-uncovered-expressions) args))
|
||||
(define (set-eval-limits eval . args)
|
||||
(apply (eval set-eval-limits) args))
|
||||
|
||||
(define-syntax parameterize*
|
||||
(syntax-rules ()
|
||||
[(parameterize* ([p1 v1] [p v] ...) body ...)
|
||||
(parameterize ([p1 v1]) (parameterize* ([p v] ...) body ...))]
|
||||
[(parameterize* () body ...)
|
||||
(begin body ...)]))
|
||||
|
||||
(define (make-evaluator* init-hook require-perms program-or-maker)
|
||||
(define cust (make-custodian))
|
||||
(define coverage? (sandbox-coverage-enabled))
|
||||
(define uncovered #f)
|
||||
(define input-ch (make-channel))
|
||||
(define result-ch (make-channel))
|
||||
(define output #f)
|
||||
(define error-output #f)
|
||||
(define limits (sandbox-eval-limits))
|
||||
(define user-running? #t)
|
||||
(define (kill-me)
|
||||
(when user-running? (set! user-running? #f) (custodian-shutdown-all cust))
|
||||
(void))
|
||||
(define (user-process)
|
||||
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
|
||||
;; first set up the environment
|
||||
(init-hook)
|
||||
((sandbox-init-hook))
|
||||
;; now read and evaluate the input program
|
||||
(evaluate-program
|
||||
(if (procedure? program-or-maker) (program-or-maker) program-or-maker)
|
||||
limits
|
||||
(and coverage? (lambda (es+get) (set! uncovered es+get))))
|
||||
(channel-put result-ch 'ok))
|
||||
;; finally wait for interaction expressions
|
||||
(let loop ([n 1])
|
||||
(let ([expr (channel-get input-ch)])
|
||||
(when (eof-object? expr) (channel-put result-ch expr) (kill-me))
|
||||
(let ([code (input->code (list expr) 'eval n)])
|
||||
(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* code)))
|
||||
(lambda () (eval* code)))])
|
||||
(channel-put result-ch
|
||||
(cons 'vals (call-with-values run list))))))
|
||||
(loop (add1 n)))))
|
||||
(define (user-eval expr)
|
||||
(let ([r (if user-running?
|
||||
(begin (channel-put input-ch expr) (channel-get result-ch))
|
||||
eof)])
|
||||
(cond [(eof-object? r) (error 'evaluator "terminated")]
|
||||
[(eq? (car r) 'exn) (raise (cdr r))]
|
||||
[else (apply values (cdr r))])))
|
||||
(define get-uncovered
|
||||
(case-lambda
|
||||
[() (get-uncovered #t)]
|
||||
[(prog?) (get-uncovered prog? 'program)]
|
||||
[(prog? src)
|
||||
(unless uncovered
|
||||
(error 'get-uncovered-expressions "no coverage information"))
|
||||
(let ([uncovered (if prog? (car uncovered) ((cadr uncovered)))])
|
||||
(if src
|
||||
(filter (lambda (x) (equal? src (syntax-source x))) uncovered)
|
||||
uncovered))]))
|
||||
(define (evaluator expr)
|
||||
(cond [(eq? expr kill-evaluator) (kill-me)]
|
||||
[(eq? expr get-output)
|
||||
(if (procedure? output) (user-eval `(,output)) output)]
|
||||
[(eq? expr get-error-output)
|
||||
(if (procedure? error-output)
|
||||
(user-eval `(,error-output)) error-output)]
|
||||
[(eq? expr get-uncovered-expressions) get-uncovered]
|
||||
[(eq? expr set-eval-limits) (lambda args (set! limits args))]
|
||||
[else (user-eval expr)]))
|
||||
(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)]
|
||||
[(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))]
|
||||
[else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)]))
|
||||
(parameterize* ; the order in these matters
|
||||
([current-custodian cust]
|
||||
[current-namespace (make-evaluation-namespace)]
|
||||
[current-inspector (make-inspector)]
|
||||
[exit-handler (lambda x (error 'exit "user code cannot exit"))]
|
||||
[current-input-port
|
||||
(let ([inp (sandbox-input)])
|
||||
(if inp
|
||||
(or (input->port inp)
|
||||
(error 'make-evaluator "bad sandbox-input: ~e" inp))
|
||||
null-input))]
|
||||
[current-output-port (make-output 'output (sandbox-output)
|
||||
(lambda (o) (set! output o))
|
||||
#f)]
|
||||
[current-error-port (make-output 'error-output (sandbox-error-output)
|
||||
(lambda (o) (set! error-output o))
|
||||
#t)]
|
||||
[current-library-collection-paths
|
||||
(filter directory-exists?
|
||||
(append (sandbox-override-collection-paths)
|
||||
(current-library-collection-paths)))]
|
||||
[sandbox-path-permissions
|
||||
(append (map (lambda (p) `(read ,p))
|
||||
(current-library-collection-paths))
|
||||
require-perms
|
||||
(sandbox-path-permissions))]
|
||||
[current-security-guard (sandbox-security-guard)]
|
||||
;; 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
|
||||
;; evaluates the program in `run-in-bg') -- so this parameterization
|
||||
;; 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)
|
||||
(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)))))
|
||||
|
||||
(define make-evaluator
|
||||
(case-lambda
|
||||
;; `input-program' is either a single argument specifying a file/string,
|
||||
;; or multiple arguments for a sequence of expressions
|
||||
[(language requires . input-program)
|
||||
(let (;; make it possible to provide #f for no language and no requires
|
||||
[lang (or language '(begin))]
|
||||
;; make it possible to use simple paths to files to require
|
||||
[reqs (cond [(not requires) '()]
|
||||
[(not (list? requires))
|
||||
(error 'make-evaluator "bad requires: ~e" requires)]
|
||||
[else (map (lambda (r) (if (pair? r) r `(file ,r)))
|
||||
requires)])])
|
||||
(make-evaluator* (init-for-language lang)
|
||||
(require-perms lang reqs)
|
||||
(lambda () (build-program lang reqs input-program))))]
|
||||
;; this is for a complete module input program
|
||||
[(input-program)
|
||||
(let ([prog (input->code (list input-program) 'program #f)])
|
||||
(unless (= 1 (length prog))
|
||||
(error 'make-evaluator "expecting a single `module' program; ~a"
|
||||
(if (zero? (length prog))
|
||||
"no program expressions given"
|
||||
"got more than a single expression")))
|
||||
(syntax-case* (car prog) (module) literal-identifier=?
|
||||
[(module modname lang body ...)
|
||||
(make-evaluator*
|
||||
void
|
||||
(require-perms (syntax-object->datum #'lang)
|
||||
(cons 'begin (syntax->list #'(body ...))))
|
||||
(car prog))]
|
||||
[_else (error 'make-evaluator "expecting a `module' program; got ~e"
|
||||
(syntax-object->datum (car prog)))]))]))
|
||||
|
||||
)
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
[(t E => :rt-err:) (err/rt-test E)]
|
||||
[(t E => :st-err:) (syntax-test #'E)]
|
||||
[(t (f x ...) => res) (test res f x ...)]
|
||||
[(t R => E more ...) (begin (t R => E) (t more ...))]
|
||||
[(t E => R more ...) (begin (t E => R) (t more ...))]
|
||||
[(t R <= E more ...) (t E => R more ...)]))
|
||||
|
||||
;; make sure that lambda/kw behaves as lambda
|
||||
|
|
|
|||
271
collects/tests/mzscheme/sandbox.ss
Normal file
271
collects/tests/mzscheme/sandbox.ss
Normal file
|
|
@ -0,0 +1,271 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(Section 'sandbox)
|
||||
|
||||
(require (lib "sandbox.ss"))
|
||||
|
||||
(let ([ev void])
|
||||
(define (run thunk)
|
||||
(with-handlers ([void (lambda (e) (list 'exn: e))])
|
||||
(call-with-values thunk (lambda vs (cons 'vals: vs)))))
|
||||
(define (run* thunk)
|
||||
(with-handlers ([void (lambda (e) (list 'exn: e))])
|
||||
(call-with-values thunk
|
||||
(case-lambda [(x) (and x #t)] [vs (cons 'vals: vs)]))))
|
||||
(define (e-match? re run thunk)
|
||||
(let ([x (run thunk)])
|
||||
(if (and (list? x) (= 2 (length x)) (eq? 'exn: (car x)) (exn? (cadr x)))
|
||||
(let ([m (exn-message (cadr x))])
|
||||
(or (regexp-match? re m) (list 'bad-exception-message: m)))
|
||||
x)))
|
||||
(define-syntax thunk (syntax-rules () [(thunk b ...) (lambda () b ...)]))
|
||||
(define-syntax t
|
||||
(syntax-rules (--eval-- --top-- => <= =err> <err=)
|
||||
[(t -?-) (void)]
|
||||
[(t -?- --eval-- more ...) (t --eval-- more ...)]
|
||||
[(t -?- --top-- more ...) (t --top-- more ...)]
|
||||
[(t --eval-- E) (test #t run* (thunk (ev `E)))]
|
||||
[(t --top-- E) (test #t run* (thunk E))]
|
||||
[(t --eval-- E => R) (test `(vals: ,R) run (thunk (ev `E)))]
|
||||
[(t --top-- E => R) (test `(vals: ,R) run (thunk E))]
|
||||
[(t --eval-- E =err> R) (test #t e-match? R run (thunk (ev `E)))]
|
||||
[(t --top-- E =err> R) (test #t e-match? R run (thunk E))]
|
||||
[(t -?- E => R more ...) (begin (t -?- E => R) (t -?- more ...))]
|
||||
[(t -?- E =err> R more ...) (begin (t -?- E =err> R) (t -?- more ...))]
|
||||
[(t -?- R <= E more ...) (t -?- E => R more ...)]
|
||||
[(t -?- R <err= E more ...) (t E =err> R more ...)]
|
||||
;; last so it doesn't match the above
|
||||
[(t -?- E more ...) (begin (t -?- E) (t -?- more ...))]))
|
||||
(define (make-prog . lines)
|
||||
(apply string-append (map (lambda (l) (string-append l "\n")) lines)))
|
||||
|
||||
(t
|
||||
|
||||
;; basic stuff, limits
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '()
|
||||
(make-prog "(define x 1)"
|
||||
"(define (id x) x)"
|
||||
"(define (plus1 x) x)"
|
||||
"(define (loop) (loop))"
|
||||
"(define (memory x) (make-vector x))")))
|
||||
(set-eval-limits ev 1 1)
|
||||
--eval--
|
||||
x => 1
|
||||
(id 1) => 1
|
||||
(id (plus1 x)) => 1
|
||||
(loop) =err> "out of time"
|
||||
(memory 1000000) =err> "out of memory"
|
||||
(printf "x = ~s\n" x) => (void)
|
||||
,eof =err> "terminated"
|
||||
x =err> "terminated"
|
||||
,eof =err> "terminated"
|
||||
|
||||
;; i/o
|
||||
--top--
|
||||
(set! ev (parameterize ([sandbox-input "3\n"] [sandbox-output 'string])
|
||||
(make-evaluator 'mzscheme '() '(define x 123))))
|
||||
--eval-- (printf "x = ~s\n" x) => (void)
|
||||
--top-- (get-output ev) => "x = 123\n"
|
||||
--eval-- (printf "x = ~s\n" x) => (void)
|
||||
--top-- (get-output ev) => "x = 123\n"
|
||||
--eval-- (printf "x*2 = ~s\n" (+ x x)) => (void)
|
||||
(printf "x*10 = ~s\n" (* 10 x)) => (void)
|
||||
--top-- (get-output ev) => "x*2 = 246\nx*10 = 1230\n"
|
||||
--eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void)
|
||||
--top-- (get-output ev) => "x*(read) = 369\n"
|
||||
--eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
|
||||
--top-- (get-output ev) => "a\nb\n"
|
||||
(get-error-output ev) => #f
|
||||
--top--
|
||||
(set! ev (parameterize ([sandbox-output 'string]
|
||||
[sandbox-error-output 'string])
|
||||
(make-evaluator 'mzscheme '())))
|
||||
--eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
|
||||
--top-- (get-output ev) => "a\n"
|
||||
(get-error-output ev) => "b\n"
|
||||
;; test kill-evaluator here
|
||||
--top--
|
||||
(kill-evaluator ev) => (void)
|
||||
--eval--
|
||||
x =err> "terminated"
|
||||
y =err> "terminated"
|
||||
,eof =err> "terminated"
|
||||
--top--
|
||||
(let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
|
||||
;; o1 -> i1 -ev-> o2 -> i2
|
||||
(set! ev (parameterize ([sandbox-input i1] [sandbox-output o2])
|
||||
(make-evaluator 'mzscheme '() '(define x 123))))
|
||||
(t --eval-- (printf "x = ~s\n" x) => (void)
|
||||
--top-- (read-line i2) => "x = 123"
|
||||
--eval-- (printf "x = ~s\n" x) => (void)
|
||||
--top-- (read-line i2) => "x = 123"
|
||||
--eval-- (printf "x*2 = ~s\n" (+ x x)) => (void)
|
||||
(printf "x*10 = ~s\n" (* 10 x)) => (void)
|
||||
--top-- (read-line i2) => "x*2 = 246"
|
||||
(read-line i2) => "x*10 = 1230"
|
||||
(fprintf o1 "3\n")
|
||||
--eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void)
|
||||
--top-- (read-line i2) => "x*(read) = 369"
|
||||
))
|
||||
|
||||
;; sexprs as a program
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x))))
|
||||
--eval--
|
||||
(id 123) => 123
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x))
|
||||
'(define fooo 999)))
|
||||
--eval--
|
||||
(id fooo) => 999
|
||||
|
||||
;; test source locations too
|
||||
--top--
|
||||
(make-evaluator 'mzscheme '() 0 1 2 '(define foo))
|
||||
=err> "program:4:0: define"
|
||||
|
||||
;; empty program for clean repls
|
||||
--top--
|
||||
(set! ev (make-evaluator '(begin) '()))
|
||||
--eval--
|
||||
(define x (+ 1 2 3)) => (void)
|
||||
x => 6
|
||||
(define x (+ x 10)) => (void)
|
||||
x => 16
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '()))
|
||||
--eval--
|
||||
(define x (+ 1 2 3)) => (void)
|
||||
x => 6
|
||||
(define x (+ x 10)) => (void)
|
||||
x => 16
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '() '(define x (+ 1 2 3))))
|
||||
--eval--
|
||||
(define x (+ x 10)) =err> "cannot change identifier"
|
||||
|
||||
;; whole program argument
|
||||
--top--
|
||||
(set! ev (make-evaluator '(module foo mzscheme (define x 1))))
|
||||
--eval--
|
||||
x => 1
|
||||
--top--
|
||||
(set! ev (make-evaluator '(module foo mzscheme (provide x) (define x 1))))
|
||||
--eval--
|
||||
x => 1
|
||||
(define x 2) =err> "cannot change identifier"
|
||||
|
||||
;; limited FS access, allowed for requires
|
||||
--top--
|
||||
(when (directory-exists? "/tmp") ; non-collects place to play with
|
||||
(let* ([mzlib (path->string (collection-path "mzlib"))]
|
||||
[list-lib (path->string (build-path mzlib "list.ss"))]
|
||||
[test-lib "/tmp/sandbox-test.ss"])
|
||||
(t --top--
|
||||
(set! ev (make-evaluator 'mzscheme '()))
|
||||
--eval--
|
||||
;; reading from collects is allowed
|
||||
(list (directory-list ,mzlib))
|
||||
(file-exists? ,list-lib) => #t
|
||||
(input-port? (open-input-file ,list-lib)) => #t
|
||||
;; writing is forbidden
|
||||
(open-output-file ,list-lib) =err> "file access denied"
|
||||
;; reading from other places is forbidden
|
||||
(directory-list "/tmp") =err> "file access denied"
|
||||
;; no network too
|
||||
(tcp-listen 12345) =err> "network access denied"
|
||||
--top--
|
||||
;; reading from a specified require is fine
|
||||
(with-output-to-file test-lib
|
||||
(lambda ()
|
||||
(printf "~s\n" '(module sandbox-test mzscheme
|
||||
(define x 123) (provide x))))
|
||||
'replace)
|
||||
(set! ev (make-evaluator 'mzscheme `(,test-lib)))
|
||||
--eval--
|
||||
x => 123
|
||||
(length (with-input-from-file ,test-lib read)) => 5
|
||||
;; the directory is still not kosher
|
||||
(directory-list "/tmp") =err> "file access denied"
|
||||
--top--
|
||||
;; should work also for module evaluators
|
||||
(set! ev (make-evaluator `(module foo mzscheme
|
||||
(require (file ,test-lib)))))
|
||||
--eval--
|
||||
x => 123
|
||||
(length (with-input-from-file ,test-lib read)) => 5
|
||||
;; the directory is still not kosher
|
||||
(directory-list "/tmp") =err> "file access denied"
|
||||
--top--
|
||||
;; explicitly allow access to /tmp
|
||||
(set! ev (parameterize ([sandbox-path-permissions
|
||||
`((read #rx#"^/tmp(?:/|$)")
|
||||
,@(sandbox-path-permissions))])
|
||||
(make-evaluator 'mzscheme '())))
|
||||
--eval--
|
||||
(length (with-input-from-file ,test-lib read)) => 5
|
||||
(list? (directory-list "/tmp"))
|
||||
(open-output-file "/tmp/blah") =err> "file access denied"
|
||||
(delete-directory "/tmp/blah") =err> "file access denied"
|
||||
)))
|
||||
|
||||
;; languages and requires
|
||||
--top--
|
||||
(set! ev (make-evaluator 'r5rs '() "(define x (eq? 'x 'X))"))
|
||||
--eval--
|
||||
x => #t
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '() "(define l null)"))
|
||||
--eval--
|
||||
(cond [null? l 0]) => 0
|
||||
(last-pair l) =err> "reference to an identifier"
|
||||
--top--
|
||||
(set! ev (make-evaluator 'beginner '() (make-prog "(define l null)"
|
||||
"(define x 3.5)")))
|
||||
--eval--
|
||||
(cond [null? l 0]) =err> "expected an open parenthesis"
|
||||
--top--
|
||||
(eq? (ev "6") (ev "(sub1 (* 2 3.5))"))
|
||||
(eq? (ev "6") (ev "(sub1 (* 2 x))"))
|
||||
--top--
|
||||
(set! ev (make-evaluator 'mzscheme '((lib "list.ss")) '()))
|
||||
--eval--
|
||||
(last-pair '(1 2 3)) => '(3)
|
||||
(last-pair null) =err> "expected argument of type"
|
||||
|
||||
;; coverage
|
||||
--top--
|
||||
(set! ev (parameterize ([sandbox-coverage-enabled #t])
|
||||
(make-evaluator 'mzscheme '()
|
||||
(make-prog "(define (foo x) (+ x 1))"
|
||||
"(define (bar x) (+ x 2))"
|
||||
"(equal? (foo 3) 4)"))))
|
||||
(pair? (get-uncovered-expressions ev))
|
||||
(pair? (get-uncovered-expressions ev #t))
|
||||
--eval--
|
||||
(foo 3) => 4
|
||||
(bar 10) => 12
|
||||
--top--
|
||||
(null? (get-uncovered-expressions ev #t))
|
||||
(pair? (get-uncovered-expressions ev)) ; no-tests coverage still the same
|
||||
|
||||
;; misc parameters
|
||||
--top--
|
||||
(set! ev (parameterize ([sandbox-init-hook
|
||||
(let ([old (sandbox-init-hook)])
|
||||
(lambda ()
|
||||
(old)
|
||||
(compile-enforce-module-constants #f)
|
||||
(compile-allow-set!-undefined #t)))])
|
||||
(make-evaluator 'mzscheme '() '(define x 123))))
|
||||
--eval--
|
||||
(set! x 456) ; would be an error without the `enforce' parameter
|
||||
x => 456
|
||||
(set! y 789) ; would be an error without the `set!' parameter
|
||||
y => 789
|
||||
|
||||
)
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user