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

revised mzlib/sandbox in scheme/sandbox

Browse Source 
svn: r7965
This commit is contained in:
Matthew Flatt 2007-12-12 13:47:02 +00:00
parent 05d372e4bf
commit 622cd0554d
21 changed files with 1361 additions and 640 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/mred-sig.ss
View File

@ -118,7 +118,8 @@ labelled-menu-item<%>
list-box% list-box%
list-control<%> list-control<%>
make-eventspace make-eventspace
make-namespace-with-mred make-gui-empty-namespace
make-gui-namespace
map-command-as-meta-key map-command-as-meta-key
menu% menu%
menu-bar% menu-bar%

39
collects/mred/mred.ss
View File

@ -1,5 +1,10 @@
(module mred mzscheme (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") (prefix wx: "private/kernel.ss")
"private/wxtop.ss" "private/wxtop.ss"
"private/app.ss" "private/app.ss"
@ -37,23 +42,22 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define mred-module-name '(lib "mred/mred.ss")) (define-namespace-anchor anchor)
(define class-module-name '(lib "scheme/class.ss"))
(define make-namespace-with-mred (define (make-gui-empty-namespace)
(opt-lambda ([flag 'mred]) (let ([ns (make-base-empty-namespace)])
(unless (memq flag '(initial mred empty)) (namespace-attach-module (namespace-anchor->empty-namespace anchor)
(raise-type-error 'make-namespace-with-mred 'mred/mred
"flag symbol, one of 'mred, 'initial, or 'empty" ns)
flag)) ns))
(let ([orig (current-namespace)]
[ns (make-namespace (if (eq? flag 'empty) 'empty 'initial))]) (define (make-gui-namespace)
(let ([ns (make-gui-empty-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-attach-module orig mred-module-name) (namespace-require 'scheme/base)
(when (eq? flag 'mred) (namespace-require 'mred/mred)
(namespace-require mred-module-name) (namespace-require 'scheme/class))
(namespace-require class-module-name))) ns))
ns)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -287,7 +291,8 @@
current-eventspace-has-standard-menus? current-eventspace-has-standard-menus?
current-eventspace-has-menu-root? current-eventspace-has-menu-root?
eventspace-handler-thread eventspace-handler-thread
make-namespace-with-mred make-gui-namespace
make-gui-empty-namespace
file-creator-and-type file-creator-and-type
current-ps-afm-file-paths current-ps-afm-file-paths
current-ps-cmap-file-paths current-ps-cmap-file-paths

656
collects/mzlib/sandbox.ss
View File

@ -1,260 +1,89 @@
(module sandbox mzscheme (module sandbox scheme/base
(require (lib "string.ss") (lib "list.ss") (lib "port.ss") (require scheme/sandbox
(lib "moddep.ss" "syntax")) (prefix-in mz: (only-in mzscheme make-namespace)))
(provide (except-out (all-from-out scheme/sandbox)
(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 make-evaluator
call-with-limits make-module-evaluator
with-limits gui?)
exn:fail:resource? (rename-out [*make-evaluator make-evaluator]
exn:fail:resource-resource) [gui? mred?]))
(define mred? (define-namespace-anchor anchor)
(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 ------------------------------------------------------------ ;; 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)))]))
(define sandbox-init-hook (make-parameter void)) (define (make-mz-namespace)
(define sandbox-input (make-parameter #f)) (let ([ns (mz:make-namespace)])
(define sandbox-output (make-parameter #f)) ;; Because scheme/sandbox needs scheme/base:
(define sandbox-error-output (make-parameter current-error-port)) (namespace-attach-module (namespace-anchor->namespace anchor)
(define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb 'scheme/base
(define sandbox-propagate-breaks (make-parameter #t)) ns)
(define sandbox-coverage-enabled (make-parameter #f)) ns))
(define sandbox-namespace-specs (define (with-ns-params thunk)
(make-parameter `(,(mz/mr make-namespace make-namespace-with-mred) (let ([v (sandbox-namespace-specs)])
#| 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 '()])
(cond (cond
[(null? todo) r] [(and (not gui?)
[(member (car todo) r) (loop (cdr todo) r)] (eq? (car v) make-base-namespace))
[else (parameterize ([sandbox-namespace-specs
(let ([path (car todo)]) (cons make-mz-namespace
(loop (map (lambda (i) (cdr v))])
(simplify-path* (resolve-module-path-index i path))) (thunk))]
(filter (lambda (i) [(and gui?
(and (module-path-index? i) (not (lib? i)))) (eq? (car v) (dynamic-require 'mred/mred 'make-gui-namespace)))
(apply append (parameterize ([sandbox-namespace-specs
(call-with-values ;; Simulate the old make-namespace-with-mred:
(lambda () (cons (lambda ()
(module-compiled-imports (let ([ns (make-mz-namespace)]
(get-module-code (car todo)))) [ns2 ((dynamic-require 'mred/mred 'make-gui-namespace))])
list)))) (namespace-attach-module ns2
(cons path r)))]))) 'mred/mred
ns)
;; Resources ---------------------------------------------------------------- (namespace-attach-module ns2
'scheme/class
(define-struct (exn:fail:resource exn:fail) (resource)) ns)
(parameterize ([current-namespace ns])
(define memory-accounting? (custodian-memory-accounting-available?)) (namespace-require 'mred)
(namespace-require 'scheme/class))
(define (call-with-limits sec mb thunk) ns))
(let ([r #f] (cdr v))])
[c (make-custodian)] (thunk))]
;; used to copy parameter changes from the nested thread [else (thunk)])))
[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) (define (literal-identifier=? x y)
(or (module-identifier=? x y) (or (free-identifier=? x y)
(eq? (if (syntax? x) (syntax-e x) x) (if (syntax? y) (syntax-e y) y)))) (eq? (syntax-e x) (syntax-e y))))
(define (make-evaluation-namespace) (define (extract-requires language requires)
(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) (define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()]) (let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms) (if (null? forms)
@ -262,334 +91,17 @@
(loop (cdr forms) (loop (cdr forms)
(syntax-case* (car forms) (require) literal-identifier=? (syntax-case* (car forms) (require) literal-identifier=?
[(require specs ...) [(require specs ...)
(append (syntax-object->datum #'(specs ...)) reqs)] (append (syntax->datum #'(specs ...)) reqs)]
[_else reqs]))))) [_else reqs])))))
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires))) (let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
(find-requires (cdr requires)) (find-requires (cdr requires))
requires)] null)]
[requires (cond [(string? language) (cons language requires)] [requires (cond [(string? language) requires]
[(not (pair? language)) requires] [(not (pair? language)) requires]
[(memq (car language) '(lib file planet)) [(memq (car language) '(lib file planet quote))
(cons language requires)] requires]
[(eq? (car language) 'begin) [(eq? (car language) 'begin)
(append (find-requires (cdr language)) requires)] (append (find-requires (cdr language)) requires)]
[else (error 'require-perms [else (error 'extract-requires
"bad language spec: ~e" language)])]) "bad language spec: ~e" language)])])
(module-specs->path-permissions requires))) 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)))]))]))
)

2
collects/mztake/load-sandbox.ss
View File

@ -13,7 +13,7 @@
;; custodian and the given error display handler. ;; custodian and the given error display handler.
(define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator)
(parameterize ([current-custodian custodian] (parameterize ([current-custodian custodian]
[current-namespace (make-namespace-with-mred)] [current-namespace (make-gui-namespace)]
[error-display-handler err-display-handler]) [error-display-handler err-display-handler])
(require/annotations initial-module annotate-module? annotator))) (require/annotations initial-module annotate-module? annotator)))

4
collects/scheme/gui/base.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme/base
(require mred)
(provide (all-from-out mred))

15
collects/scheme/gui/dynamic.ss Normal file
View File

@ -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)))

2
collects/scheme/private/old-procs.ss
View File

@ -24,7 +24,7 @@
[old (variable-reference->empty-namespace (#%variable-reference reflect-var))]) [old (variable-reference->empty-namespace (#%variable-reference reflect-var))])
(namespace-attach-module old 'mzscheme new) (namespace-attach-module old 'mzscheme new)
(parameterize ([current-namespace new]) (parameterize ([current-namespace new])
(namespace-require 'mzscheme)) (namespace-require/copy 'mzscheme))
new)])) new)]))
(define (free-identifier=?* a b) (define (free-identifier=?* a b)

607
collects/scheme/sandbox.ss Normal file
View File

@ -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)))]))))

28
collects/scribblings/gui/dynamic.scrbl Normal file
View File

@ -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].}

12
collects/scribblings/gui/gui.scrbl
View File

@ -4,20 +4,21 @@
@title[#:tag-prefix '(lib "scribblings/gui/gui.scrbl") @title[#:tag-prefix '(lib "scribblings/gui/gui.scrbl")
#:tag "top"]{PLT Scheme GUI: MrEd} #: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 This reference manual describes the MrEd GUI toolbox that is part of
PLT Scheme. See @secref[#:doc '(lib "scribblings/guide/guide.scrbl") PLT Scheme. See @secref[#:doc '(lib "scribblings/guide/guide.scrbl")
"mred"] in @italic{@link["../guide/index.html"]{A Guide to PLT "mred"] in @italic{@link["../guide/index.html"]{A Guide to PLT
Scheme}} for an introduction to MrEd. Scheme}} for an introduction to MrEd.
@defmodule*/no-declare[(mred)]{The @schememodname[mred] module provides @defmodule*/no-declare[(scheme/gui/base)]{The
all of the class, interface, and procedure bindings defined in this @schememodname[scheme/gui/base] module provides all of the class,
manual.} interface, and procedure bindings defined in this manual.}
@defmodulelang*/no-declare[(scheme/gui)]{The @defmodulelang*/no-declare[(scheme/gui)]{The
@schememodname[scheme/gui] language combines all bindings of 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[] @table-of-contents[]
@ -27,6 +28,7 @@ manual.}
@include-section["guide.scrbl"] @include-section["guide.scrbl"]
@include-section["reference.scrbl"] @include-section["reference.scrbl"]
@include-section["config.scrbl"] @include-section["config.scrbl"]
@include-section["dynamic.scrbl"]
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------

24
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -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?]{ namespace?]{
Like @scheme[make-namespace], but the @scheme[(lib "mred.ss" Like @scheme[make-base-empty-namespace], but with
"mred")] module of the current namespace is attached. In addition, by @scheme[scheme/class] and @schememodname[scheme/gui/base] also
default, the namespace is initialized by importing the @filepath{mred.ss} attached to the result namespace.}
module and MzLib's @indexed-file{class.ss} module into the
namespace's top-level environment.
@defproc[(make-gui-namespace)
namespace?]{
The @scheme['initial] and @scheme['empty] flags control the namespace Like @scheme[make-base-namespace], but with @scheme[scheme/class] and
creation in the same way as for @scheme[make-namespace], except that @schememodname[scheme/gui/base] also required into the top-level
the @filepath{mred.ss} module is attached to the created namespace (along environment of the result namespace.}
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.
}

6
collects/scribblings/reference/mz.ss
View File

@ -10,10 +10,8 @@
(all-from-out scribble/eval) (all-from-out scribble/eval)
(all-from-out scheme/contract)) (all-from-out scheme/contract))
(require (for-label scheme (require (for-label scheme))
"to-do.ss")) (provide (for-label (all-from-out scheme)))
(provide (for-label (all-from-out scheme)
(all-from-out "to-do.ss")))
(define AllUnix "Unix and Mac OS X") (define AllUnix "Unix and Mac OS X")
(provide AllUnix) (provide AllUnix)

559
collects/scribblings/reference/sandbox.scrbl Normal file
View File

@ -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].}

3
collects/scribblings/reference/security.scrbl
View File

@ -8,9 +8,10 @@
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@include-section["namespaces.scrbl"] @include-section["namespaces.scrbl"]
@include-section["eval.scrbl"] @include-section["eval.scrbl"]
@include-section["module-reflect.scrbl"]
@include-section["security-guards.scrbl"] @include-section["security-guards.scrbl"]
@include-section["custodians.scrbl"] @include-section["custodians.scrbl"]
@include-section["thread-groups.scrbl"] @include-section["thread-groups.scrbl"]
@include-section["struct-inspectors.scrbl"] @include-section["struct-inspectors.scrbl"]
@include-section["code-inspectors.scrbl"] @include-section["code-inspectors.scrbl"]
@include-section["module-reflect.scrbl"] @include-section["sandbox.scrbl"]

8
collects/scribblings/reference/to-do.ss
View File

@ -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)))

3
collects/scribblings/scribble/style.scrbl
View File

@ -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 not merely @scheme[schemefont] or @scheme[verbatim], to refer to a
specific sequence of characters. 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 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 (i.e., a sentence-terminating period goes inside the
quotation marks). Of course, this rule does not apply for quotation quotation marks). Of course, this rule does not apply for quotation

2
collects/slideshow/slides-to-picts.ss
View File

@ -13,7 +13,7 @@
(define get-slides-as-picts (define get-slides-as-picts
(opt-lambda (file w h c? [stop-after #f]) (opt-lambda (file w h c? [stop-after #f])
(let ([ns (make-namespace-with-mred)] (let ([ns (make-gui-namespace)]
[orig-ns (current-namespace)] [orig-ns (current-namespace)]
[param ((current-module-name-resolver) '(lib "param.ss" "slideshow") #f #f)] [param ((current-module-name-resolver) '(lib "param.ss" "slideshow") #f #f)]
[core ((current-module-name-resolver) '(lib "core.ss" "slideshow") #f #f)] [core ((current-module-name-resolver) '(lib "core.ss" "slideshow") #f #f)]

2
collects/slideshow/tutorial-show.ss
View File

@ -584,7 +584,7 @@
(define (run-example-talk f) (define (run-example-talk f)
(let ([c (make-custodian)]) (let ([c (make-custodian)])
(parameterize ([current-namespace (make-namespace-with-mred)] (parameterize ([current-namespace (make-gui-namespace)]
[current-command-line-arguments [current-command-line-arguments
(vector (path->string (vector (path->string
(build-path (collection-path "slideshow") (build-path (collection-path "slideshow")

4
collects/tests/mred/random.ss
View File

@ -1083,12 +1083,12 @@
(parameterize ([current-namespace n]) (parameterize ([current-namespace n])
(namespace-mapped-symbols)))] (namespace-mapped-symbols)))]
[expect-n (list* 'mred@ 'mred^ [expect-n (list* 'mred@ 'mred^
(append (get-all (let ([n (make-namespace)]) (append (get-all (let ([n (make-base-namespace)])
(parameterize ([current-namespace n]) (parameterize ([current-namespace n])
(namespace-require '(lib "class.ss"))) (namespace-require '(lib "class.ss")))
n)) n))
in-top-level))] in-top-level))]
[actual-n (get-all (make-namespace-with-mred))]) [actual-n (get-all (make-gui-namespace))])
(for-each (for-each
(lambda (i) (lambda (i)
(unless (memq i expect-n) (unless (memq i expect-n)

2
src/mzscheme/src/env.c
View File

@ -2481,7 +2481,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (!genv) { if (!genv) {
scheme_wrong_syntax("require", NULL, src_find_id, scheme_wrong_syntax("require", NULL, src_find_id,
"namespace mismatch; reference (phase %d) to a module" "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); env->genv->phase, modname, mod_defn_phase);
return NULL; return NULL;
} }

2
src/mzscheme/src/eval.c
View File

@ -1732,7 +1732,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
if (!menv) { if (!menv) {
scheme_wrong_syntax("link", NULL, varname, scheme_wrong_syntax("link", NULL, varname,
"namespace mismatch; reference (phase %d) to a module" "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", " appears in module: %D",
env->phase, env->phase,
modname, modname,