diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 840fe4a678..537a6650a3 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -635,6 +635,15 @@ by this function. `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 @@ -676,6 +685,7 @@ by this function. * 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.) > (get-output evaluator) When this is used with an evaluator that was created with diff --git a/collects/handin-server/overridden-collects/readme.txt b/collects/handin-server/overridden-collects/readme.txt new file mode 100644 index 0000000000..a73c86303f --- /dev/null +++ b/collects/handin-server/overridden-collects/readme.txt @@ -0,0 +1,6 @@ +This directory is used (by default) as a first root for searching +collections when evaluating user code. This means that PLT libraries +that appear here will be used instead of ones in the PLT tree or the +user-local collections. Use it to override collections that are safe +for testing, for example -- avoid using actual gui. See also the +documentation for `sandbox-override-collection-paths' in "doc.txt". diff --git a/collects/handin-server/sandbox.ss b/collects/handin-server/sandbox.ss index 7c4efc0f43..abfb39f565 100644 --- a/collects/handin-server/sandbox.ss +++ b/collects/handin-server/sandbox.ss @@ -6,6 +6,7 @@ coverage-enabled namespace-specs sandbox-reader + sandbox-override-collection-paths sandbox-security-guard sandbox-path-permissions sandbox-input @@ -48,6 +49,10 @@ (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 @@ -69,13 +74,13 @@ (path->bytes (simplify-path* path)) (bytes-append #"(?:$|" sep-re #")")))))) - (define lib-permissions + (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))) - (current-library-collection-paths)))) + (map (lambda (p) (list 'read (dir-path->bytes-re p))) libs))) - (define sandbox-path-permissions (make-parameter lib-permissions)) + (define sandbox-path-permissions + (make-parameter (get-lib-permissions (current-library-collection-paths)))) (define (path-ok? bpath ok) (cond [(bytes? ok) (equal? bpath ok)] @@ -286,6 +291,11 @@ (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 @@ -308,8 +318,10 @@ (get-output-bytes o1)))) o))] [else (error 'make-evaluator "bad output: ~e" out)]))] - [sandbox-path-permissions (append (require-perms language teachpacks) - (sandbox-path-permissions))] + [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