revised mzlib/sandbox in scheme/sandbox
svn: r7965 original commit: 622cd0554d57fc1c5f1dc03c69504703181eec18
This commit is contained in:
Matthew Flatt
parent
ea7f084922
commit
2ae2c75f25
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user