From 433c9a57ec1cae5e251f89466d1f084af74b240d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 6 Apr 2007 08:56:23 +0000 Subject: [PATCH] new sandbox in mzlib svn: r5873 --- collects/handin-server/checker.ss | 2 +- collects/handin-server/doc.txt | 199 +------ collects/handin-server/sandbox.ss | 402 +------------ .../private/sandbox-coverage.ss} | 5 +- collects/mzlib/sandbox.ss | 532 ++++++++++++++++++ collects/tests/mzscheme/kw.ss | 2 +- collects/tests/mzscheme/sandbox.ss | 271 +++++++++ 7 files changed, 827 insertions(+), 586 deletions(-) rename collects/{handin-server/private/coverage.ss => mzlib/private/sandbox-coverage.ss} (93%) create mode 100644 collects/mzlib/sandbox.ss create mode 100644 collects/tests/mzscheme/sandbox.ss diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 6de2b7ac6c..e7ee140042 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -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 ...)] diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index d14cba5854..d3d7a0bdc2 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -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_ diff --git a/collects/handin-server/sandbox.ss b/collects/handin-server/sandbox.ss index c9f994b418..6f1248428a 100644 --- a/collects/handin-server/sandbox.ss +++ b/collects/handin-server/sandbox.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))) ) diff --git a/collects/handin-server/private/coverage.ss b/collects/mzlib/private/sandbox-coverage.ss similarity index 93% rename from collects/handin-server/private/coverage.ss rename to collects/mzlib/private/sandbox-coverage.ss index f1eec092eb..0231936eaf 100644 --- a/collects/handin-server/private/coverage.ss +++ b/collects/mzlib/private/sandbox-coverage.ss @@ -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 diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss new file mode 100644 index 0000000000..580742731f --- /dev/null +++ b/collects/mzlib/sandbox.ss @@ -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)))]))])) + + ) diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index e339060df3..782f49c5bf 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -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 diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss new file mode 100644 index 0000000000..79ebe8b951 --- /dev/null +++ b/collects/tests/mzscheme/sandbox.ss @@ -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> 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 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 + + ) + + )