From 622cd0554d57fc1c5f1dc03c69504703181eec18 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 12 Dec 2007 13:47:02 +0000 Subject: [PATCH] revised mzlib/sandbox in scheme/sandbox svn: r7965 --- collects/mred/mred-sig.ss | 3 +- collects/mred/mred.ss | 41 +- collects/mzlib/sandbox.ss | 672 +++--------------- collects/mztake/load-sandbox.ss | 2 +- collects/scheme/gui/base.ss | 4 + collects/scheme/gui/dynamic.ss | 15 + collects/scheme/private/old-procs.ss | 2 +- collects/scheme/sandbox.ss | 607 ++++++++++++++++ collects/scribblings/gui/dynamic.scrbl | 28 + collects/scribblings/gui/gui.scrbl | 12 +- collects/scribblings/gui/miscwin-funcs.scrbl | 24 +- collects/scribblings/reference/mz.ss | 6 +- collects/scribblings/reference/sandbox.scrbl | 559 +++++++++++++++ collects/scribblings/reference/security.scrbl | 3 +- collects/scribblings/reference/to-do.ss | 8 - collects/scribblings/scribble/style.scrbl | 3 + collects/slideshow/slides-to-picts.ss | 2 +- collects/slideshow/tutorial-show.ss | 2 +- collects/tests/mred/random.ss | 4 +- src/mzscheme/src/env.c | 2 +- src/mzscheme/src/eval.c | 2 +- 21 files changed, 1361 insertions(+), 640 deletions(-) create mode 100644 collects/scheme/gui/base.ss create mode 100644 collects/scheme/gui/dynamic.ss create mode 100644 collects/scheme/sandbox.ss create mode 100644 collects/scribblings/gui/dynamic.scrbl create mode 100644 collects/scribblings/reference/sandbox.scrbl delete mode 100644 collects/scribblings/reference/to-do.ss diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index 34a0752bcc..3ddd2598e6 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -118,7 +118,8 @@ labelled-menu-item<%> list-box% list-control<%> make-eventspace -make-namespace-with-mred +make-gui-empty-namespace +make-gui-namespace map-command-as-meta-key menu% menu-bar% diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index f10f1c5259..9f9bbeebe6 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -1,5 +1,10 @@ (module mred mzscheme - (require (lib "etc.ss") + (require (only scheme/base + define-namespace-anchor + namespace-anchor->empty-namespace + make-base-empty-namespace) + scheme/class + (lib "etc.ss") (prefix wx: "private/kernel.ss") "private/wxtop.ss" "private/app.ss" @@ -37,23 +42,22 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define mred-module-name '(lib "mred/mred.ss")) - (define class-module-name '(lib "scheme/class.ss")) + (define-namespace-anchor anchor) - (define make-namespace-with-mred - (opt-lambda ([flag 'mred]) - (unless (memq flag '(initial mred empty)) - (raise-type-error 'make-namespace-with-mred - "flag symbol, one of 'mred, 'initial, or 'empty" - flag)) - (let ([orig (current-namespace)] - [ns (make-namespace (if (eq? flag 'empty) 'empty 'initial))]) - (parameterize ([current-namespace ns]) - (namespace-attach-module orig mred-module-name) - (when (eq? flag 'mred) - (namespace-require mred-module-name) - (namespace-require class-module-name))) - ns))) + (define (make-gui-empty-namespace) + (let ([ns (make-base-empty-namespace)]) + (namespace-attach-module (namespace-anchor->empty-namespace anchor) + 'mred/mred + ns) + ns)) + + (define (make-gui-namespace) + (let ([ns (make-gui-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require 'scheme/base) + (namespace-require 'mred/mred) + (namespace-require 'scheme/class)) + ns)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -287,7 +291,8 @@ current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread - make-namespace-with-mred + make-gui-namespace + make-gui-empty-namespace file-creator-and-type current-ps-afm-file-paths current-ps-cmap-file-paths diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss index 839fd81e34..1d3299dcaf 100644 --- a/collects/mzlib/sandbox.ss +++ b/collects/mzlib/sandbox.ss @@ -1,595 +1,107 @@ -(module sandbox mzscheme - (require (lib "string.ss") (lib "list.ss") (lib "port.ss") - (lib "moddep.ss" "syntax")) +(module sandbox scheme/base + (require scheme/sandbox + (prefix-in mz: (only-in mzscheme make-namespace))) + (provide (except-out (all-from-out scheme/sandbox) + make-evaluator + make-module-evaluator + gui?) + (rename-out [*make-evaluator make-evaluator] + [gui? mred?])) - (provide mred? - sandbox-init-hook - sandbox-reader - sandbox-input - sandbox-output - sandbox-error-output - sandbox-propagate-breaks - sandbox-coverage-enabled - sandbox-namespace-specs - sandbox-override-collection-paths - sandbox-security-guard - sandbox-path-permissions - sandbox-network-guard - sandbox-eval-limits - kill-evaluator - break-evaluator - set-eval-limits - put-input - get-output - get-error-output - get-uncovered-expressions - make-evaluator - call-with-limits - with-limits - exn:fail:resource? - exn:fail:resource-resource) + (define-namespace-anchor anchor) - (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)])) + ;; Compatbility: + ;; * recognize 'r5rs, etc, and wrap them as a list. + ;; * 'begin form of reqs + ;; * more agressively extract requires from lang and reqs + (define *make-evaluator + (case-lambda + [(lang reqs . progs) + (with-ns-params + (lambda () + (let ([beg-req? (and (list? reqs) + (pair? reqs) + (eq? 'begin (car reqs)))] + [reqs (or reqs '())] + [lang (or lang '(begin))]) + (keyword-apply + make-evaluator + '(#:allow-read) + (list (extract-requires lang reqs)) + (case lang + [(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced) + (list 'special lang)] + [else lang]) + (if beg-req? null reqs) + (append + (if beg-req? (cdr reqs) null) + progs)))))] + [(mod) + (with-ns-params + (lambda () + (make-module-evaluator mod)))])) - ;; Configuration ------------------------------------------------------------ + (define (make-mz-namespace) + (let ([ns (mz:make-namespace)]) + ;; Because scheme/sandbox needs scheme/base: + (namespace-attach-module (namespace-anchor->namespace anchor) + 'scheme/base + ns) + ns)) - (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 current-error-port)) - (define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb - (define sandbox-propagate-breaks (make-parameter #t)) - (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))) - - (require (only (lib "modhelp.ss" "syntax" "private") module-path-v?)) - - ;; 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))))) - ;; turns a module spec to a simple one (except for lib specs) - (define (simple-modspec mod) - (cond [(and (pair? mod) (eq? 'lib (car mod))) #f] - [(module-path-v? mod) - (simplify-path* (resolve-module-path mod #f))] - [(not (and (pair? mod) (pair? (cdr mod)))) - ;; don't know what this is, leave as is - #f] - [(eq? 'only (car mod)) - (simple-modspec (cadr mod))] - [(eq? 'rename (car mod)) - (simple-modspec (cadr mod))] - [(and (eq? 'prefix (car mod)) (pair? (cddr mod))) - (simple-modspec (caddr mod))] - [else #f])) - (let loop ([todo (filter values (map simple-modspec mods))] - [r '()]) + (define (with-ns-params thunk) + (let ([v (sandbox-namespace-specs)]) (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 memory-accounting? (custodian-memory-accounting-available?)) - - (define (call-with-limits sec mb thunk) - (let ([r #f] - [c (make-custodian)] - ;; used to copy parameter changes from the nested thread - [p current-preserved-thread-cell-values]) - (when (and mb memory-accounting?) - (custodian-limit-memory c (* mb 1024 1024) c)) - (parameterize ([current-custodian c]) - ;; The nested-thread can die on a time-out or memory-limit, - ;; and never throws an exception, so we never throw an error, - ;; just assume the a death means the custodian was shut down - ;; due to memory limit. Note: cannot copy the - ;; parameterization in this case. - (with-handlers ([exn:fail? (lambda (e) - (unless r (set! r (cons #f 'memory))))]) - (call-in-nested-thread - (lambda () - (define this (current-thread)) - (define timer - (thread (lambda () - (sleep sec) - ;; even in this case there are no parameters - ;; to copy, since it is on a different thread - (set! r (cons #f 'time)) - (kill-thread this)))) - (set! r - (with-handlers ([void (lambda (e) (list (p) raise e))]) - (call-with-values thunk (lambda vs (list* (p) values vs))))) - (kill-thread timer)))) - (custodian-shutdown-all c) - (unless r (error 'call-with-limits "internal error")) - ;; apply parameter changes first - (when (car r) (p (car r))) - (if (pair? (cdr r)) - (apply (cadr r) (cddr r)) - (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r)) - (current-continuation-marks) - (cdr r))))))) - - (define-syntax with-limits - (syntax-rules () - [(with-limits sec mb body ...) - (call-with-limits sec mb (lambda () body ...))])) - - ;; Execution ---------------------------------------------------------------- - + [(and (not gui?) + (eq? (car v) make-base-namespace)) + (parameterize ([sandbox-namespace-specs + (cons make-mz-namespace + (cdr v))]) + (thunk))] + [(and gui? + (eq? (car v) (dynamic-require 'mred/mred 'make-gui-namespace))) + (parameterize ([sandbox-namespace-specs + ;; Simulate the old make-namespace-with-mred: + (cons (lambda () + (let ([ns (make-mz-namespace)] + [ns2 ((dynamic-require 'mred/mred 'make-gui-namespace))]) + (namespace-attach-module ns2 + 'mred/mred + ns) + (namespace-attach-module ns2 + 'scheme/class + ns) + (parameterize ([current-namespace ns]) + (namespace-require 'mred) + (namespace-require 'scheme/class)) + ns)) + (cdr v))]) + (thunk))] + [else (thunk)]))) + (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)))) + (or (free-identifier=? x y) + (eq? (syntax-e x) (syntax-e 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 (extract-requires 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]))))) + reqs + (loop (cdr forms) + (syntax-case* (car forms) (require) literal-identifier=? + [(require specs ...) + (append (syntax->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)] + (find-requires (cdr requires)) + null)] + [requires (cond [(string? language) requires] [(not (pair? language)) requires] - [(memq (car language) '(lib file planet)) - (cons language requires)] + [(memq (car language) '(lib file planet quote)) + requires] [(eq? (car language) 'begin) (append (find-requires (cdr language)) requires)] - [else (error 'require-perms + [else (error 'extract-requires "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) - (read-accept-infix-dot #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 (quote ,mod))) - (module->namespace `(quote ,(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 bg-run->thread (if mred? - (lambda (ignored) - ((mz/mr void eventspace-handler-thread) (current-eventspace))) - values)) - (define null-input (open-input-bytes #"")) - - (define (kill-evaluator eval) (eval kill-evaluator)) - (define (break-evaluator eval) (eval break-evaluator)) - (define (set-eval-limits eval . args) ((eval set-eval-limits) args)) - (define (put-input eval . args) (apply (eval put-input) args)) - (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 (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 input #f) - (define output #f) - (define error-output #f) - (define limits (sandbox-eval-limits)) - (define user-thread #t) ; set later to the thread - (define orig-cust (current-custodian)) - (define (user-kill) - (when user-thread - (let ([t user-thread]) - (set! user-thread #f) - (custodian-shutdown-all cust) - (kill-thread t))) ; just in case - (void)) - (define (user-break) - (when user-thread (break-thread user-thread))) - (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) (user-kill)) - (with-handlers ([void (lambda (exn) - (channel-put result-ch (cons 'exn exn)))]) - (let* ([code (input->code (list expr) 'eval n)] - [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-thread - (begin (channel-put input-ch expr) - (let loop () - (with-handlers ([(lambda (e) - (and (sandbox-propagate-breaks) - (exn:break? e))) - (lambda (e) - (user-break) - (loop))]) - (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 (output-getter p) (if (procedure? p) (user-eval `(,p)) p)) - (define input-putter - (case-lambda - [() (input-putter input-putter)] - [(arg) (cond [(not input) - (error 'put-input "evaluator input is not 'pipe")] - [(or (string? arg) (bytes? arg)) - (display arg input) (flush-output input)] - [(eof-object? arg) (close-output-port input)] - [(eq? arg input-putter) input] - [else (error 'put-input "bad input: ~e" arg)])])) - (define (evaluator expr) - (cond [(eq? expr kill-evaluator) (user-kill)] - [(eq? expr break-evaluator) (user-break)] - [(eq? expr set-eval-limits) (lambda (args) (set! limits args))] - [(eq? expr put-input) input-putter] - [(eq? expr get-output) (output-getter output)] - [(eq? expr get-error-output) (output-getter error-output)] - [(eq? expr get-uncovered-expressions) get-uncovered] - [else (user-eval expr)])) - (define linked-outputs? #f) - (define (make-output what out set-out! allow-link?) - (cond [(not out) (open-output-nowhere)] - [(and (procedure? out) (procedure-arity-includes? out 0)) (out)] - [(output-port? out) out] - [(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)] - [(memq out '(bytes string)) - (let* ([bytes? (eq? 'bytes out)] - ;; the following doesn't really matter: they're the same - [out ((if bytes? open-output-bytes open-output-string))]) - (set-out! - (lambda () - (parameterize ([current-custodian orig-cust]) - (let ([buf (get-output-bytes out #t)]) - (if bytes? buf (bytes->string/utf-8 buf #\?)))))) - out)] - [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) - (parameterize* ; the order in these matters - (;; create a sandbox context first - [current-custodian cust] - [current-thread-group (make-thread-group)] - [current-namespace (make-evaluation-namespace)] - ;; set up the IO context - [current-input-port - (let ([inp (sandbox-input)]) - (cond - [(not inp) null-input] - [(input->port inp) => values] - [(and (procedure? inp) (procedure-arity-includes? inp 0)) (inp)] - [(eq? 'pipe inp) - (let-values ([(i o) (make-pipe)]) (set! input o) i)] - [else (error 'make-evaluator "bad sandbox-input: ~e" inp)]))] - [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)] - ;; paths - [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))] - ;; general info - [current-command-line-arguments '#()] - ;; restrict the sandbox context from this point - [current-security-guard (sandbox-security-guard)] - [exit-handler (lambda x (error 'exit "user code cannot exit"))] - [current-inspector (make-inspector)] - ;; This breaks: [current-code-inspector (make-inspector)] - ;; 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)]) - (set! user-thread (bg-run->thread (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 (or (pair? r) (symbol? r)) - r - `(file ,(path->string (simplify-path* 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 '() (car prog))] - [_else (error 'make-evaluator "expecting a `module' program; got ~e" - (syntax-object->datum (car prog)))]))])) - - ) + requires))) diff --git a/collects/mztake/load-sandbox.ss b/collects/mztake/load-sandbox.ss index 91f7806564..6dbafe9fcb 100644 --- a/collects/mztake/load-sandbox.ss +++ b/collects/mztake/load-sandbox.ss @@ -13,7 +13,7 @@ ;; custodian and the given error display handler. (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) (parameterize ([current-custodian custodian] - [current-namespace (make-namespace-with-mred)] + [current-namespace (make-gui-namespace)] [error-display-handler err-display-handler]) (require/annotations initial-module annotate-module? annotator))) diff --git a/collects/scheme/gui/base.ss b/collects/scheme/gui/base.ss new file mode 100644 index 0000000000..dd18b64540 --- /dev/null +++ b/collects/scheme/gui/base.ss @@ -0,0 +1,4 @@ +#lang scheme/base + +(require mred) +(provide (all-from-out mred)) diff --git a/collects/scheme/gui/dynamic.ss b/collects/scheme/gui/dynamic.ss new file mode 100644 index 0000000000..fd895694d3 --- /dev/null +++ b/collects/scheme/gui/dynamic.ss @@ -0,0 +1,15 @@ +#lang scheme/base + +(provide gui-available? + gui-dynamic-require) + +(define (gui-available?) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (dynamic-require ''#%mred-kernel #f) + #t)) + +(define-namespace-anchor anchor) + +(define (gui-dynamic-require sym) + (parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)]) + (dynamic-require 'mred/mred sym))) diff --git a/collects/scheme/private/old-procs.ss b/collects/scheme/private/old-procs.ss index 941989d896..4725642405 100644 --- a/collects/scheme/private/old-procs.ss +++ b/collects/scheme/private/old-procs.ss @@ -24,7 +24,7 @@ [old (variable-reference->empty-namespace (#%variable-reference reflect-var))]) (namespace-attach-module old 'mzscheme new) (parameterize ([current-namespace new]) - (namespace-require 'mzscheme)) + (namespace-require/copy 'mzscheme)) new)])) (define (free-identifier=?* a b) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss new file mode 100644 index 0000000000..9e5ea4ce71 --- /dev/null +++ b/collects/scheme/sandbox.ss @@ -0,0 +1,607 @@ +#lang scheme/base + +(require scheme/port + syntax/moddep + scheme/gui/dynamic) + +(provide gui? + sandbox-init-hook + sandbox-reader + sandbox-input + sandbox-output + sandbox-error-output + sandbox-propagate-breaks + sandbox-coverage-enabled + sandbox-namespace-specs + sandbox-override-collection-paths + sandbox-security-guard + sandbox-path-permissions + sandbox-network-guard + sandbox-eval-limits + kill-evaluator + break-evaluator + set-eval-limits + put-input + get-output + get-error-output + get-uncovered-expressions + make-evaluator + make-module-evaluator + call-with-limits + with-limits + exn:fail:resource? + exn:fail:resource-resource) + +(define gui? (gui-available?)) + +(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding + (syntax-rules () + [(mz/mr mzval mrsym) + (if gui? (gui-dynamic-require '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 current-error-port)) +(define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb +(define sandbox-propagate-breaks (make-parameter #t)) +(define sandbox-coverage-enabled (make-parameter #f)) + +(define sandbox-namespace-specs + (make-parameter `(,(mz/mr make-base-namespace make-gui-namespace) + #| 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) + (if (symbol? path) + #f + (simplify-path (cleanse-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))))) + ;; turns a module spec to a simple one (except for lib specs) + (define (simple-modspec mod) + (cond [(and (pair? mod) (eq? 'lib (car mod))) #f] + [(module-path? mod) + (simplify-path* (resolve-module-path mod #f))] + [(not (and (pair? mod) (pair? (cdr mod)))) + ;; don't know what this is, leave as is + #f] + [(eq? 'only (car mod)) + (simple-modspec (cadr mod))] + [(eq? 'rename (car mod)) + (simple-modspec (cadr mod))] + [(and (eq? 'prefix (car mod)) (pair? (cddr mod))) + (simple-modspec (caddr mod))] + [else #f])) + (let loop ([todo (filter values (map simple-modspec mods))] + [r '()]) + (cond + [(null? todo) r] + [(member (car todo) r) (loop (cdr todo) r)] + [else + (let ([path (car todo)]) + (loop (filter values + (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 memory-accounting? (custodian-memory-accounting-available?)) + +(define (call-with-limits sec mb thunk) + (let ([r #f] + [c (make-custodian)] + ;; used to copy parameter changes from the nested thread + [p current-preserved-thread-cell-values]) + (when (and mb memory-accounting?) + (custodian-limit-memory c (* mb 1024 1024) c)) + (parameterize ([current-custodian c]) + ;; The nested-thread can die on a time-out or memory-limit, + ;; and never throws an exception, so we never throw an error, + ;; just assume the a death means the custodian was shut down + ;; due to memory limit. Note: cannot copy the + ;; parameterization in this case. + (with-handlers ([exn:fail? (lambda (e) + (unless r (set! r (cons #f 'memory))))]) + (call-in-nested-thread + (lambda () + (define this (current-thread)) + (define timer + (thread (lambda () + (sleep sec) + ;; even in this case there are no parameters + ;; to copy, since it is on a different thread + (set! r (cons #f 'time)) + (kill-thread this)))) + (set! r + (with-handlers ([void (lambda (e) (list (p) raise e))]) + (call-with-values thunk (lambda vs (list* (p) values vs))))) + (kill-thread timer)))) + (custodian-shutdown-all c) + (unless r (error 'call-with-limits "internal error")) + ;; apply parameter changes first + (when (car r) (p (car r))) + (if (pair? (cdr r)) + (apply (cadr r) (cddr r)) + (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r)) + (current-continuation-marks) + (cdr 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 (free-identifier=? x y) + (eq? (syntax-e x) (syntax-e y)))) + +(define-namespace-anchor anchor) + +(define (make-evaluation-namespace) + (let* ([specs (sandbox-namespace-specs)] + [new-ns ((car specs))] + [orig-ns (namespace-anchor->empty-namespace anchor)] + [mods (cdr specs)]) + (parameterize ([current-namespace orig-ns]) + (for-each (lambda (mod) (dynamic-require mod #f)) mods)) + (parameterize ([current-namespace new-ns]) + (for-each (lambda (ms) (namespace-attach-module orig-ns ms)) + mods)) + new-ns)) + +(define (extract-required language requires) + (let* ([requires (cond [(string? language) (cons language requires)] + [(not (pair? language)) requires] + [(memq (car language) '(lib file planet quote)) + (cons language requires)] + [(eq? (car language) 'begin) requires] + [else (error 'extract-required + "bad language spec: ~e" language)])]) + 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 + #f (car inps) + (list source n (and n 0) n (and n 1))) + r))))])))) + +(define ((init-for-language language)) + (cond [(or (not (pair? language)) + (not (eq? 'special (car language)))) + (void)] + [(eq? (cadr language) 'r5rs) + (read-case-sensitive #f) + (read-square-bracket-as-paren #f) + (read-curly-brace-as-paren #f) + (read-accept-infix-dot #f)] + [(memq (cadr 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'). +;; +;; FIXME: inserting `#%require's here is bad if the language has a +;; `#%module-begin' that processes top-level forms specially. +;; A more general solution would be to create anew module that exports +;; the given language plus all of the given extra requires. +;; +;; We use `#%requre' because, unlike the `require' of scheme/base, +;; it comes from `#%kernel', so it's always present through +;; transitive requires. +(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 [(decode-language language) + => (lambda (l) + (use-lang l))] + [(module-path? language) + (use-lang language)] + [(and (list? language) (eq? 'begin (car language))) + (append language body)] + [else (error 'make-evaluator "bad language spec: ~e" language)]))) + +(define (decode-language language) + (cond [(and (list? language) + (= 2 (length language)) + (eq? (car language) 'special) + (memq (cadr language) teaching-langs)) + `(lib ,(format "htdp-~a.ss" (cadr language)) "lang")] + [(equal? language '(special r5rs)) + `(lib "lang.ss" "r5rs")] + [else #f])) + +;; 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 (quote ,mod))) + (module->namespace `(quote ,(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 bg-run->thread (if gui? + (lambda (ignored) + ((mz/mr void eventspace-handler-thread) (current-eventspace))) + values)) +(define null-input (open-input-bytes #"")) + +(define (kill-evaluator eval) (eval kill-evaluator)) +(define (break-evaluator eval) (eval break-evaluator)) +(define (set-eval-limits eval . args) ((eval set-eval-limits) args)) +(define (put-input eval . args) (apply (eval put-input) args)) +(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 (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 input #f) + (define output #f) + (define error-output #f) + (define limits (sandbox-eval-limits)) + (define user-thread #t) ; set later to the thread + (define orig-cust (current-custodian)) + (define (user-kill) + (when user-thread + (let ([t user-thread]) + (set! user-thread #f) + (custodian-shutdown-all cust) + (kill-thread t))) ; just in case + (void)) + (define (user-break) + (when user-thread (break-thread user-thread))) + (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) (user-kill)) + (with-handlers ([void (lambda (exn) + (channel-put result-ch (cons 'exn exn)))]) + (let* ([code (input->code (list expr) 'eval n)] + [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-thread + (begin (channel-put input-ch expr) + (let loop () + (with-handlers ([(lambda (e) + (and (sandbox-propagate-breaks) + (exn:break? e))) + (lambda (e) + (user-break) + (loop))]) + (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 (output-getter p) (if (procedure? p) (user-eval `(,p)) p)) + (define input-putter + (case-lambda + [() (input-putter input-putter)] + [(arg) (cond [(not input) + (error 'put-input "evaluator input is not 'pipe")] + [(or (string? arg) (bytes? arg)) + (display arg input) (flush-output input)] + [(eof-object? arg) (close-output-port input)] + [(eq? arg input-putter) input] + [else (error 'put-input "bad input: ~e" arg)])])) + (define (evaluator expr) + (cond [(eq? expr kill-evaluator) (user-kill)] + [(eq? expr break-evaluator) (user-break)] + [(eq? expr set-eval-limits) (lambda (args) (set! limits args))] + [(eq? expr put-input) input-putter] + [(eq? expr get-output) (output-getter output)] + [(eq? expr get-error-output) (output-getter error-output)] + [(eq? expr get-uncovered-expressions) get-uncovered] + [else (user-eval expr)])) + (define linked-outputs? #f) + (define (make-output what out set-out! allow-link?) + (cond [(not out) (open-output-nowhere)] + [(and (procedure? out) (procedure-arity-includes? out 0)) (out)] + [(output-port? out) out] + [(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)] + [(memq out '(bytes string)) + (let* ([bytes? (eq? 'bytes out)] + ;; the following doesn't really matter: they're the same + [out ((if bytes? open-output-bytes open-output-string))]) + (set-out! + (lambda () + (parameterize ([current-custodian orig-cust]) + (let ([buf (get-output-bytes out #t)]) + (if bytes? buf (bytes->string/utf-8 buf #\?)))))) + out)] + [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) + (parameterize* ; the order in these matters + (;; create a sandbox context first + [current-custodian cust] + [current-thread-group (make-thread-group)] + [current-namespace (make-evaluation-namespace)] + ;; set up the IO context + [current-input-port + (let ([inp (sandbox-input)]) + (cond + [(not inp) null-input] + [(input->port inp) => values] + [(and (procedure? inp) (procedure-arity-includes? inp 0)) (inp)] + [(eq? 'pipe inp) + (let-values ([(i o) (make-pipe)]) (set! input o) i)] + [else (error 'make-evaluator "bad sandbox-input: ~e" inp)]))] + [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)] + ;; paths + [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)) + (module-specs->path-permissions require-perms) + (sandbox-path-permissions))] + ;; general info + [current-command-line-arguments '#()] + ;; restrict the sandbox context from this point + [current-security-guard (sandbox-security-guard)] + [exit-handler (lambda x (error 'exit "user code cannot exit"))] + [current-inspector (make-inspector)] + ;; This breaks: [current-code-inspector (make-inspector)] + ;; 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)]) + (set! user-thread (bg-run->thread (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 + (lambda (language requires #:allow-read [allow null] . input-program) + ;; `input-program' is either a single argument specifying a file/string, + ;; or multiple arguments for a sequence of expressions + (let (;; make it possible to provide #f for no language and no requires + [lang language] + ;; make it possible to use simple paths to files to require + [reqs (cond [(not (list? requires)) + (error 'make-evaluator "bad requires: ~e" requires)] + [else + (map (lambda (r) + (if (or (pair? r) (symbol? r)) + r + `(file ,(path->string (simplify-path* r))))) + requires)])]) + (make-evaluator* (init-for-language lang) + (append (extract-required (or (decode-language lang) + lang) + reqs) + allow) + (lambda () (build-program lang reqs input-program)))))) + +(define make-module-evaluator + (lambda (input-program #:allow-read [allow null]) + ;; this is for a complete module 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 allow (car prog))] + [_else (error 'make-evaluator "expecting a `module' program; got ~e" + (syntax->datum (car prog)))])))) + diff --git a/collects/scribblings/gui/dynamic.scrbl b/collects/scribblings/gui/dynamic.scrbl new file mode 100644 index 0000000000..a33df354cc --- /dev/null +++ b/collects/scribblings/gui/dynamic.scrbl @@ -0,0 +1,28 @@ +#lang scribble/doc +@require["common.ss" + (for-label scheme/gui/dynamic)] + +@title{Dynamic Loading} + +@defmodule[scheme/gui/dynamic]{The @schememodname[scheme/gui/dynamic] +library provides functiosn for dynamically accessing the PLT Scheme +GUI toolbox, instead of directly requiring @scheme[scheme/gui] or +@scheme[scheme/gui/base].} + +@defproc[(gui-available?) boolean?]{ + +Returns @scheme[#t] if dynamic access to the GUI bindings are +available---that is, that the program is being run as a +@exec{mred}-based application, as opposed to a pure +@exec{mzscheme}-based application, and that GUI modules are attached +to the namespace in which @scheme[scheme/gui/dynamic] was +instantiated. + +This predicate can be used in code that optionally uses GUI elements +when they are available.} + + +@defproc[(gui-dynamic-require [sym symbol?]) any]{ + +Like @scheme[dynamic-require], but specifically to access exports of +@scheme[scheme/gui/base].} diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 39cf5404bd..3c48abc3ab 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -4,20 +4,21 @@ @title[#:tag-prefix '(lib "scribblings/gui/gui.scrbl") #:tag "top"]{PLT Scheme GUI: MrEd} -@declare-exporting[mred scheme/gui] +@declare-exporting[scheme/gui/base scheme/gui] This reference manual describes the MrEd GUI toolbox that is part of PLT Scheme. See @secref[#:doc '(lib "scribblings/guide/guide.scrbl") "mred"] in @italic{@link["../guide/index.html"]{A Guide to PLT Scheme}} for an introduction to MrEd. -@defmodule*/no-declare[(mred)]{The @schememodname[mred] module provides -all of the class, interface, and procedure bindings defined in this -manual.} +@defmodule*/no-declare[(scheme/gui/base)]{The +@schememodname[scheme/gui/base] module provides all of the class, +interface, and procedure bindings defined in this manual.} @defmodulelang*/no-declare[(scheme/gui)]{The @schememodname[scheme/gui] language combines all bindings of the -@schememodname[scheme] language and the @schememodname[mred] module.} +@schememodname[scheme] language and the +@schememodname[scheme/gui/base] modules.} @table-of-contents[] @@ -27,6 +28,7 @@ manual.} @include-section["guide.scrbl"] @include-section["reference.scrbl"] @include-section["config.scrbl"] +@include-section["dynamic.scrbl"] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 4b4d14ad0c..d94b97c19b 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -424,22 +424,16 @@ If the AppleEvent reply contains a value that cannot be } -@defproc[(make-namespace-with-mred [flag (one-of/c 'mred 'initial 'empty) 'mred]) +@defproc[(make-gui-empty-namespace) namespace?]{ -Like @scheme[make-namespace], but the @scheme[(lib "mred.ss" - "mred")] module of the current namespace is attached. In addition, by - default, the namespace is initialized by importing the @filepath{mred.ss} - module and MzLib's @indexed-file{class.ss} module into the - namespace's top-level environment. +Like @scheme[make-base-empty-namespace], but with +@scheme[scheme/class] and @schememodname[scheme/gui/base] also +attached to the result namespace.} +@defproc[(make-gui-namespace) + namespace?]{ -The @scheme['initial] and @scheme['empty] flags control the namespace - creation in the same way as for @scheme[make-namespace], except that - the @filepath{mred.ss} module is attached to the created namespace (along - with the transitive closure of its imports). The @scheme['mred] flag - is like @scheme['initial], but also imports the @filepath{mred.ss} module - and MzLib's @indexed-file{class.ss} module into the namespace's - top-level environment. - -} +Like @scheme[make-base-namespace], but with @scheme[scheme/class] and +@schememodname[scheme/gui/base] also required into the top-level +environment of the result namespace.} diff --git a/collects/scribblings/reference/mz.ss b/collects/scribblings/reference/mz.ss index 0038ffd640..4995102039 100644 --- a/collects/scribblings/reference/mz.ss +++ b/collects/scribblings/reference/mz.ss @@ -10,10 +10,8 @@ (all-from-out scribble/eval) (all-from-out scheme/contract)) - (require (for-label scheme - "to-do.ss")) - (provide (for-label (all-from-out scheme) - (all-from-out "to-do.ss"))) + (require (for-label scheme)) + (provide (for-label (all-from-out scheme))) (define AllUnix "Unix and Mac OS X") (provide AllUnix) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl new file mode 100644 index 0000000000..af1221c7a7 --- /dev/null +++ b/collects/scribblings/reference/sandbox.scrbl @@ -0,0 +1,559 @@ +#lang scribble/doc +@(require "mz.ss" + scheme/sandbox + (for-label scheme/sandbox + #;(only-in mred/mred make-gui-namespace))) + +@title{Sandboxed Evaluation} + +@note-lib-only[scheme/sandbox] + +The @schememodname[scheme/sandbox] module provides utilities for +creating ``sandboxed'' evaluators, which are configured in a +particular way and can have restricted filesystem access, network +access, and memory use. + +@defproc*[([(make-evaluator [language (or/c module-path? + (list/c (one-of/c 'special) symbol?) + (cons/c (one-of/c 'begin) list?))] + [requires (listof (or/c module-path? path?))] + [input-program any/c] ... + [#:allow-read allow (listof (or/c module-path? path?))]) + (any/c . -> . any)] + [(make-module-evaluator [module-decl (or/c syntax? pair?)] + [#:allow-read allow (listof (or/c module-path? path?))]) + (any/c . -> . any)])]{ + +The @scheme[make-evaluator] function creates an evaluator with a +@scheme[language] and @scheme[requires] specification, and starts +evaluating the given @scheme[input-program]s. The +@scheme[make-module-evaluator] function creates an evaluator that +works in the context of a given module. The result in either case is a +function for further evaluation. + +The returned evaluator operates in an isolated and limited +environment. In particular, filesystem access is restricted. The +@scheme[allow] argument extends the set of files that are readable by +the evaluator to include the specified modules and their imports +(transitively). When @scheme[language] is a module path and when +@scheme[requires] is provided, the indicated modules are implicitly +included in the @scheme[allow] list. + +Each @scheme[input-program] or @scheme[module-decl] argument provides +a program in one of the following forms: + +@itemize{ + + @item{an input port used to read the program;} + + @item{a string or a byte string holding the complete input;} + + @item{a path that names a file holding the input; or} + + @item{an S-expression or a @tech{syntax object}, which is evaluated + as with @scheme[eval]; see also + @scheme[get-uncovered-expressions].} + +} + +In the first three cases above, the program is read using +@scheme[sandbox-reader], with line-counting enabled for sensible error +messages, and with @scheme['program] as the source (used for testing +coverage). In the last case, the input is expected to be the complete +program, and is converted to a @tech{syntax object} (using +@scheme['program] as the source), unless it already is a @tech{syntax +object}. + +The returned evaluator function accepts an additional expressions +(each time it is called) in essentially the same form: a string or +byte string holding a sequence of expressions, a path for a file +holding expressions, an S-expression, or a @tech{syntax object}. If +the evaluator receives an @scheme[eof] value, it is terminated and +raises errors thereafter. See also @scheme[kill-evaluator], which +terminates the evaluator without raising an exception. + +For @scheme[make-evaluator], multiple @scheme[input-program]s are +effectively concatenated to form a single program. The way that the +@scheme[input-program]s are evaluated depends on the @scheme[language] +argument: + +@itemize{ + + @item{The @scheme[language] argument can be a module path (i.e., a + datum that matches the grammar for @scheme[_module-path] of + @scheme[require]). + + In this case, the @scheme[input-program]s are automatically + wrapped in a @scheme[module], and the resulting evaluator works + within the resulting module's namespace.} + + @item{The @scheme[language] argument can be a list starting with + @scheme['special], which indicates a built-in language with + special input configuration. The possible values are + @scheme['(special r5rs)] or a value indicating a teaching + language: @scheme['(special beginner)], @scheme['(special + beginner-abbr)], @scheme['(special intermediate)], + @scheme['(special intermediate-lambda)], or @scheme['(special + advanced)]. + + In this case, the @scheme[input-program]s are automatically + wrapped in a @scheme[module], and the resulting evaluator works + within the resulting module's namespace. In addition, certain + parameters (such as such as @scheme[read-accept-infix-dot]) are + set to customize reading programs from strings and ports.} + + @item{Finally, @scheme[language] can be a list whose first element is + @scheme['begin]. + + In this case, a new namespace is created using + @scheme[sandbox-namespace-specs], which by default creates a + new namespace using @scheme[make-base-namespace] or + @scheme[make-gui-namespace] (depending on @scheme[gui?]). + + In the new namespace, @scheme[language] is evaluated as an + expression to further initialize the namespace.} + +} + +The @scheme[requires] list adds additional imports to the module or +namespace for the @scheme[input-program]s, even in the case that +@scheme[require] is not made available through the @scheme[language]. + +The following examples illustrate the difference between an evaluator +that puts the program in a module and one that merely initializes a +top-level namespace: + +@interaction[ +(define base-module-eval + (code:comment #, @t{a module cannot have free variables...}) + (make-evaluator 'scheme/base '() '(define (f) later))) +(define base-module-eval + (make-evaluator 'scheme/base '() '(define (f) later) + '(define later 5))) +(base-module-eval '(f)) + +(define base-top-eval + (code:comment #, @t{non-module code can have free variables:}) + (make-evaluator '(begin) '() '(define (f) later))) +(base-top-eval '(+ 1 2)) +(base-top-eval '(define later 5)) +(base-top-eval '(f)) +] + +The @scheme[make-module-evaluator] function is essentially a +restriction of @scheme[make-evaluator], where the program must be a +module, and all imports are part of the program: + +@schemeblock[ +(define base-module-eval2 + (code:comment #, @t{equivalent to @scheme[base-module-eval]:}) + (make-module-evaluator '(module m scheme/base + (define (f) later) + (define later 5)))) +] + +In all cases, the evaluator operates in an isolated and limited +environment: + +@itemize{ + + @item{It uses a new custodian and namespace. When @scheme[gui?] is + true, it is also runs in its own eventspace.} + + @item{The evaluator works under the @scheme[sandbox-security-guard], + which restricts file system and network access.} + + @item{Each evaluation is wrapped in a @scheme[call-with-limits]; see + also @scheme[sandbox-eval-limits] and @scheme[set-eval-limits].} +} + +Evaluation can also be instrumented to track evaluation information +when @scheme[sandbox-coverage-enabled] is set. Exceptions (both syntax +and run-time) are propagated in the usual way to the caller of the +evaluation function.} + +@; ---------------------------------------------------------------------- + +@section{Customizing Evaluators} + +The evaluators that @scheme[make-evaluator] creates can be customized +via several parameters. These parameters affect newly created +evaluators; changing them has no effect on already-running evaluators. + +@defparam[sandbox-init-hook thunk (-> any)]{ + +A parameter that determines a thunk to be called for initializing a +new evaluator. The hook is called just before the program is +evaluated in a newly-created evaluator context. It can be used to +setup environment parameters related to reading, writing, evaluation, +and so on. Certain languages (@scheme['(r5rs)] and the teaching +languages) have initializations specific to the language; the hook is +used after that initialization, so it can override settings.} + + +@defparam[sandbox-reader proc (any/c . -> . any)]{ + +A parameter that determines a function to reads all expressions from +@scheme[(current-input-port)]. The function is used to read program +source for an evaluator when a string. byte string, or port is +supplies. The reader function receives a value to be used as input +source (i.e., the first argument to @scheme[read-syntax]), and it +should return a list of @tech{syntax objects}. The default reader +calls @scheme[read-syntax], accumulating results in a list until it +receives @scheme[eof].} + + +@defparam[sandbox-input in (or/c false/c + string? bytes? + input-port? + (one-of/c 'pipe) + (-> input-port?))]{ + +A parameter that determines the initial @scheme[current-input-port] +setting for a newly created evaluator. It defaults to @scheme[#f], +which creates an empty port. The following other values are allowed: + +@itemize{ + + @item{a string or byte string, which is converted to a port using + @scheme[open-input-string] or @scheme[open-input-bytes];} + + @item{an input port;} + + @item{the symbol @scheme['pipe], which triggers the creation of a + pipe, where @scheme[put-input] can return the output end of the + pipe or write directly to it;} + + @item{a thunk, which is called to obtain a port (e.g., using + @scheme[current-input-port] means that the evaluator input is + the same as the calling context's input).} + +}} + + +@defparam[sandbox-output in (or/c false/c + output-port? + (one-of/c 'pipe 'bytes 'string) + (-> output-port?))]{ + +A parameter that determines the initial @scheme[current-output-port] +setting for a newly created evaluator. It defaults to @scheme[#f], +which creates a port that discrds all data. The following other +values are allowed: + +@itemize{ + + @item{an output port, which is used as-is;} + + @item{the symbol @scheme['bytes], which causes @scheme[get-output] + to return the complete output as a byte string;} + + @item{the symbol @scheme['string], which is similar to + @scheme['bytes], but makes @scheme[get-output] produce a + string;} + + @item{the symbol @scheme['pipe], which triggers the creation of a + pipe, where @scheme[get-output] returns the input end of the + pipe;} + + @item{a thunk, which is called to obtain a port (e.g., using + @scheme[current-output-port] means that the evaluator output is + not diverted).} + +}} + + +@defparam[sandbox-error-output in (or/c false/c + output-port? + (one-of/c 'pipe 'bytes 'string) + (-> output-port?))]{ + +Like @scheme[sandbox-output], but for the initial +@scheme[current-error-port] value. An evaluator's error output is set +after its output, so using @scheme[current-output-port] for this +parameter value means that the error port is the same as the +evaluator's initial output port. + +The default is @scheme[current-error-port], which means that the error +output of the generated evaluator goes to the calling context's error +port.} + + +@defboolparam[sandbox-coverage-enabled enabled?]{ + +A parameter that controls whether syntactic coverage information is +collected by sandbox evaluators. Use +@scheme[get-uncovered-expressions] to retrieve coverage information.} + + +@defparam[sandbox-namespace-specs spec (cons/c (-> namespace?) + (listof module-path?))]{ + +A parameter that holds a list of values that specify how to create a +namespace for evaluation in @scheme[make-evaluator] or +@scheme[make-module-evaluator]. The first item in the list is a thunk +that creates the namespace, and the rest are module paths for modules +that to be attached to the created namespace using +@scheme[namespace-attach-module]. + +The default is @scheme[(list make-base-namespace)] if @scheme[gui?] is +@scheme[#f], @scheme[(list make-gui-namespace)] if @scheme[gui?] is +@scheme[#t]. + +The module paths are needed for sharing module instantiations between +the sandbox and the caller. For example, sandbox code that returns +@scheme[posn] values (from the @schemeidfont{lang/posn} module) will +not be recognized as such by your own code by default, since the +sandbox will have its own instance of @schemeidfont{lang/posn} and +thus its own struct type for @scheme[posn]s. To be able to use such +values, include @scheme['lang/posn] in the list of module paths. + +When testing code that uses a teaching language, the following piece +of code can be helpful: + +@schemeblock[ +(sandbox-namespace-specs + (let ([specs (sandbox-namespace-specs)]) + `(,(car specs) + ,@(cdr specs) + lang/posn + ,@(if mred? '(mrlib/cache0image-snip) '())))) +]} + + +@defparam[sandbox-override-collection-paths paths (listof path-string?)]{ + +A parameter that determines a list of collection directories to prefix +@scheme[current-library-collection-paths] in an evaluator. This +parameter useful for cases when you want to test code using an +alternate, test-friendly version of a collection, for example, testing +code that uses GUI (like the @schememodname[htdp/world] teachpack) can +be done using a fake library that provides the same interface but no +actual interaction. The default is @scheme[null].} + + +@defparam[sandbox-security-guard guard security-guard?]{ + +A parameter that determines the initial +@scheme[(current-security-guard)] for sandboxed evaluations. The +default forbids all filesystem I/O except for things in +@scheme[sandbox-path-permissions], and it uses +@scheme[sandbox-network-guard] for network connections.} + + +@defparam[sandbox-path-permissions perms + (listof (list/c (one-of/c 'execute 'write 'delete + 'read 'exists) + (or/c byte-regexp? bytes? string? path?)))]{ + +A parameter that configures the behavior of the default sandbox +security guard by listing paths and access modes that are allowed for +them. The contents of this parameter is a list of specifications, +each an access mode and a byte-regexp for paths that are granted this +access. + +The access mode symbol is one of: @scheme['execute], @scheme['write], +@scheme['delete], @scheme['read], or @scheme['exists]. These symbols are +in decreasing order: each implies access for the following modes too +(e.g., @scheme['read] allows reading or checking for existence). + +The path regexp is used to identify paths that are granted access. It +can also be given as a path (or a string or a byte string), which is +(made into a complete path, cleansed, simplified, and then) converted +to a regexp that allows the path and sub-directories; e.g., +@scheme["/foo/bar"] applies to @scheme["/foo/bar/baz"]. + +The default value is null, but when an evaluator is created, it is +augmented by @scheme['read] permissions that make it possible to use +collection libraries (including +@scheme[sandbox-override-collection-paths]). See +@scheme[make-evalautor] for more information.} + + +@defparam[sandbox-network-guard proc + (symbol? + (or/c (and/c string? immutable?) false/c) + (or/c (integer-in 1 65535) false/c) + (one-of/c 'server 'client) + . -> . any)]{ + +A parameter that specifieds a procedure to be used (as is) by the +default @scheme[sandbox-security-guard]. The default forbids all +network connection.} + + +@defparam[sandbox-eval-limits limits (or/c + (list/c (or/c exact-nonnegative-integer? + false/c) + (or/c exact-nonnegative-integer? + false/c)) + false/c)]{ + +A parameter that determines the default limits on @italic{each} use of +a @scheme[make-evaluator] function, including the initial evaluation +of the input program. Its value should be a list of two numbers, the +first is a timeout value in seconds, and the second is a memory limit +in megabytes. Either one can be @scheme[#f] for disabling the +corresponding limit; alternately, the parameter can be set to +@scheme[#f] to disable all limits (in case more are available in +future versions). + +When limits are set, @scheme[call-with-limits] (see below) is wrapped +around each use of the evaluator, so consuming too much time or memory +results in an exception. You can change the limits of a running +evaluator using @scheme[set-eval-limits].} + +@; ---------------------------------------------------------------------- + +@section{Interacting with Evaluators} + +The following functions actually pass themselves to the given +procedure. An evaluator procedure recognizes these procedures (using +@scheme[eq?]) to take an appropriate action. + + +@defproc[(kill-evaluator [evaluator (any/c . -> . any)]) void?]{ + +Releases the resources that are held by @scheme[evaluator] by shutting +down the evaluator's custodian. Attempting to use an evaluator after +killing raises an exception, and attempts to kill a dead evaluator are +ignored. + +Killing an evaluator is similar to sending an @scheme[eof] value to +the evaluator, except that an @scheme[eof] value will raise an error +immediately.} + + +@defproc[(set-eval-limits [evaluator (any/c . -> . any)] + [secs (or/c exact-nonnegative-integer? false/c)] + [mb (or/c exact-nonnegative-integer? false/c)]) void?]{ + +Changes the per-expression limits that @scheme[evaluator] uses to +@scheme[sec] seconds and @scheme[mb] megabytes (either one can be +@scheme[#f], indicating no limit). + +This procedure should be used to modify an existing evaluator limits, +because changing the @scheme[sandbox-eval-limits] parameter does not +affect existing evaluators. See also @scheme[call-with-limits].} + + +@defproc*[([(put-input [evaluator (any/c . -> . any)]) output-port?] + [(put-input [evaluator (any/c . -> . any)] + [i/o (or/c bytes? string? eof-object?)]) void?])]{ + +If @scheme[(sandbox-input)] is @scheme['pipe] when an evaluator is +created, then this procedure can be used to retrieve the output port +end of the pipe (when used with no arguments), or to add a string or a +byte string into the pipe. It can also be used with @scheme[eof], +which closes the pipe.} + + +@defproc*[([(get-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)] + [(get-error-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)])]{ + +Returns the output or error-output of the @scheme[evaluator], +in a way that depends on the setting of @scheme[(sandbox-output)] or +@scheme[(sandbox-error-output)] when the evaluator was created: + +@itemize{ + + @item{if it was @scheme['pipe], then @scheme[get-output] returns the + input port end of the created pipe;} + + @item{if it was @scheme['bytes] or @scheme['string], then the result + is the accumulated output, and the output is directed to a new + output string or byte string (so each call returns a different + piece of the evaluator's output);} + + @item{otherwise, it returns @scheme[#f].} +}} + + +@defproc[(get-uncovered-expressions [evaluator (any/c . -> . any)] + [prog? any/c #t] + [src any/c 'program]) + (listof syntax?)]{ + +Retrieves uncovered expression from an evaluator, as longs as the +@scheme[sandbox-coverage-enabled] parameter had a true value when the +evaluator was created. Otherwise, and exception is raised to indicate +that no coverage information is available. + +The @scheme[prog?] argument specifies whether to obtain expressions that +were uncovered after only the original input program was evaluated +(@scheme[#t]) or after all later uses of the evaluator (@scheme[#f]). +Using @scheme[#t] retrieves a list that is saved after the input +program is evaluated, and before the evaluator is used, so the result is +always the same. + +A @scheme[#t] value of @scheme[prog?] is useful for testing student +programs to find out whether a submission has sufficient test coverage +built in. A @scheme[#f] value is useful for writing test suites for a +program to ensure that your tests cover the whole code. + +The second optional argument, @scheme[src], specifies that the result +should be filtered to hold only @tech{syntax objects} whose source +matches @scheme[src]. The default, @scheme['program], is the source +associated with the input program by the default +@scheme[sandbox-reader]---which provides only @tech{syntax objects} +from the input program (and not from required modules or expressions +that were passed to the evaluator). A @scheme[#f] avoids filtering. + +The resulting list of @tech{syntax objects} has at most one expression +for each position and span. Thus, the contents may be unreliable, but +the position information is reliable (i.e., it always indicates source +code that would be painted red in DrScheme when coverage information +is used). + +Note that if the input program is a sequence of syntax values, either +make sure that they have @scheme['program] as the source field, or use +the @scheme[src] argument. Using a sequence of S-expressions (not +@tech{syntax objects}) for an input program leads to unreliable +coverage results, since each expression may be assigned a single +source location.} + +@; ---------------------------------------------------------------------- + +@section{Miscellaneous} + +@defthing[gui? boolean?]{ + +True if the @schememodname[scheme/gui] module can be used, @scheme[#f] +otherwise. Various aspects of the @schememodname[scheme/sandbox] +library change when the GUI library is available, such as using a new +eventspace for each evaluator.} + + +@defproc[(call-with-limits [secs (or/c exact-nonnegative-integer? false/c)] + [mb (or/c exact-nonnegative-integer? false/c)] + [thunk (-> any)]) + any]{ + +Executes the given @scheme[thunk] with memory and time restrictions: +if execution consumes more than @scheme[mb] megabytes or more than +@scheme[sec] seconds, then the computation is aborted and the +@exnraise[exn:fail:resource]. Otherwise the result of the thunk is +returned as usual (a value, multiple values, or an exception). Each +of the two limits can be @scheme[#f] to indicate the absence of a +limit. See also @scheme[custodian-limit-memory] for information on +memory limits. + +Sandboxed evaluators use @scheme[call-with-limits], according to the +@scheme[sandbox-eval-limits] setting and uses of +@scheme[set-eval-limits]: each expression evaluation is protected from +timeouts and memory problems. Use @scheme[call-with-limits] directly +only to limit a whole testing session, instead of each expression.} + + +@defform[(with-limits mb-expr body-expr body ...)]{ + +A macro version of @scheme[call-with-limits].} + + +@defproc*[([(exn:fail:resource? [v any/c]) boolean?] + [(exn:fail:resource-resource [exn exn:fail:resource?]) + (one-of/c 'time 'memory)])]{ + +A predicate and accessor for exceptions that are raised by +@scheme[call-with-limits]. The @scheme[resource] field holds a symbol, +either @scheme['time] or @scheme['memory].} diff --git a/collects/scribblings/reference/security.scrbl b/collects/scribblings/reference/security.scrbl index bcba164358..8b4a85dd26 100644 --- a/collects/scribblings/reference/security.scrbl +++ b/collects/scribblings/reference/security.scrbl @@ -8,9 +8,10 @@ @;------------------------------------------------------------------------ @include-section["namespaces.scrbl"] @include-section["eval.scrbl"] +@include-section["module-reflect.scrbl"] @include-section["security-guards.scrbl"] @include-section["custodians.scrbl"] @include-section["thread-groups.scrbl"] @include-section["struct-inspectors.scrbl"] @include-section["code-inspectors.scrbl"] -@include-section["module-reflect.scrbl"] +@include-section["sandbox.scrbl"] diff --git a/collects/scribblings/reference/to-do.ss b/collects/scribblings/reference/to-do.ss deleted file mode 100644 index 0731e6a7cc..0000000000 --- a/collects/scribblings/reference/to-do.ss +++ /dev/null @@ -1,8 +0,0 @@ - -(module to-do mzscheme - - (define list-mutableof #t) - (define list-mutable/c #t) - (define cons-mutable/c #t) - - (provide (all-defined))) diff --git a/collects/scribblings/scribble/style.scrbl b/collects/scribblings/scribble/style.scrbl index 23867600a1..e2dee89e4c 100644 --- a/collects/scribblings/scribble/style.scrbl +++ b/collects/scribblings/scribble/style.scrbl @@ -45,6 +45,9 @@ variable, meta-variable, etc.---use @scheme[schemeidfont] (e.g., as in not merely @scheme[schemefont] or @scheme[verbatim], to refer to a specific sequence of characters. +Refrain from referring to documentation ``above'' or ``below,'' and +instead have a hyperlink point to the right place. + Use American style for quotation marks and punctuation at the end of quotation marks (i.e., a sentence-terminating period goes inside the quotation marks). Of course, this rule does not apply for quotation diff --git a/collects/slideshow/slides-to-picts.ss b/collects/slideshow/slides-to-picts.ss index ed43e995f9..fb0f156d2d 100644 --- a/collects/slideshow/slides-to-picts.ss +++ b/collects/slideshow/slides-to-picts.ss @@ -13,7 +13,7 @@ (define get-slides-as-picts (opt-lambda (file w h c? [stop-after #f]) - (let ([ns (make-namespace-with-mred)] + (let ([ns (make-gui-namespace)] [orig-ns (current-namespace)] [param ((current-module-name-resolver) '(lib "param.ss" "slideshow") #f #f)] [core ((current-module-name-resolver) '(lib "core.ss" "slideshow") #f #f)] diff --git a/collects/slideshow/tutorial-show.ss b/collects/slideshow/tutorial-show.ss index 833a91e26f..b5d687f99a 100644 --- a/collects/slideshow/tutorial-show.ss +++ b/collects/slideshow/tutorial-show.ss @@ -584,7 +584,7 @@ (define (run-example-talk f) (let ([c (make-custodian)]) - (parameterize ([current-namespace (make-namespace-with-mred)] + (parameterize ([current-namespace (make-gui-namespace)] [current-command-line-arguments (vector (path->string (build-path (collection-path "slideshow") diff --git a/collects/tests/mred/random.ss b/collects/tests/mred/random.ss index dcfb5c13e7..8afe28c406 100644 --- a/collects/tests/mred/random.ss +++ b/collects/tests/mred/random.ss @@ -1083,12 +1083,12 @@ (parameterize ([current-namespace n]) (namespace-mapped-symbols)))] [expect-n (list* 'mred@ 'mred^ - (append (get-all (let ([n (make-namespace)]) + (append (get-all (let ([n (make-base-namespace)]) (parameterize ([current-namespace n]) (namespace-require '(lib "class.ss"))) n)) in-top-level))] - [actual-n (get-all (make-namespace-with-mred))]) + [actual-n (get-all (make-gui-namespace))]) (for-each (lambda (i) (unless (memq i expect-n) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 723937a66f..efeb6dbab8 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2481,7 +2481,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (!genv) { scheme_wrong_syntax("require", NULL, src_find_id, "namespace mismatch; reference (phase %d) to a module" - " %D that is not instantiated (phase %d)", + " %D that is not available (phase %d)", env->genv->phase, modname, mod_defn_phase); return NULL; } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index ec05d39dac..fe981c3f5f 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1732,7 +1732,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, if (!menv) { scheme_wrong_syntax("link", NULL, varname, "namespace mismatch; reference (phase %d) to a module" - " %D that is not instantiated (phase %d); reference" + " %D that is not available (phase %d); reference" " appears in module: %D", env->phase, modname,