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

Some more let' -> define' uses.

Browse Source
This commit is contained in:
Eli Barzilay 2011-08-20 06:15:22 -04:00
parent da3c6c9be2
commit bc0c466233
1 changed files with 263 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

528
collects/racket/sandbox.rkt
View File

@ -149,42 +149,42 @@
(cons perm ps))) (cons perm ps)))
permission-order)) permission-order))
(lambda () (lambda ()
(let ([ps (sandbox-path-permissions)]) (define ps (sandbox-path-permissions))
(or (hash-ref t ps #f) (or (hash-ref t ps #f)
(let ([c (compress-permissions ps)]) (hash-set! t ps c) c)))))) (let ([c (compress-permissions ps)]) (hash-set! t ps c) c)))))
;; similar to the security guard, only with a single mode for simplification; ;; similar to the security guard, only with a single mode for simplification;
;; assumes valid mode and simplified path ;; assumes valid mode and simplified path
(define (check-sandbox-path-permissions path needed) (define (check-sandbox-path-permissions path needed)
(let ([bpath (path->bytes path)] (define bpath (path->bytes path))
[perms (compressed-path-permissions)]) (define perms (compressed-path-permissions))
(ormap (lambda (rx) (regexp-match? rx bpath)) (cdr (assq needed perms))))) (ormap (lambda (rx) (regexp-match? rx bpath)) (cdr (assq needed perms))))
(define sandbox-network-guard (define sandbox-network-guard
(make-parameter (lambda (what . xs) (make-parameter (lambda (what . xs)
(error what "network access denied: ~e" xs)))) (error what "network access denied: ~e" xs))))
(define (make-default-sandbox-guard) (define (make-default-sandbox-guard)
(let ([orig-security (current-security-guard)]) (define orig-security (current-security-guard))
(make-security-guard (make-security-guard
orig-security orig-security
(lambda (what path modes) (lambda (what path modes)
(when path (when path
(let ([spath (parameterize ([current-security-guard orig-security]) (define spath (parameterize ([current-security-guard orig-security])
(simplify-path* path))] (simplify-path* path)))
[maxperm (define maxperm
;; assumes that the modes are valid (ie, in the above list) ;; assumes that the modes are valid (ie, in the above list)
(cond [(null? modes) (error 'default-sandbox-guard (cond [(null? modes) (error 'default-sandbox-guard
"got empty mode list for ~e and ~e" "got empty mode list for ~e and ~e"
what path)] what path)]
[(null? (cdr modes)) (car modes)] ; common case [(null? (cdr modes)) (car modes)] ; common case
[else (foldl (lambda (x max) (if (perm<=? max x) x max)) [else (foldl (lambda (x max) (if (perm<=? max x) x max))
(car modes) (cdr modes))])]) (car modes) (cdr modes))]))
(unless (check-sandbox-path-permissions spath maxperm) (unless (check-sandbox-path-permissions spath maxperm)
(error what "`~a' access denied for ~a" (error what "`~a' access denied for ~a"
(string-append* (add-between (map symbol->string modes) "+")) (string-append* (add-between (map symbol->string modes) "+"))
path))))) path))))
(lambda args (apply (sandbox-network-guard) args))))) (lambda args (apply (sandbox-network-guard) args))))
(define sandbox-security-guard (define sandbox-security-guard
(make-parameter make-default-sandbox-guard (make-parameter make-default-sandbox-guard
@ -208,9 +208,9 @@
(define sandbox-make-logger (make-parameter current-logger)) (define sandbox-make-logger (make-parameter current-logger))
(define (compute-permissions paths+require-perms) (define (compute-permissions paths+require-perms)
(let-values ([(paths require-perms) (partition path? paths+require-perms)]) (define-values [paths require-perms] (partition path? paths+require-perms))
(append (map (lambda (p) `(read ,(path->bytes p))) paths) (append (map (lambda (p) `(read ,(path->bytes p))) paths)
(module-specs->path-permissions require-perms)))) (module-specs->path-permissions require-perms)))
;; computes permissions that are needed for require specs (`read-bytecode' for ;; computes permissions that are needed for require specs (`read-bytecode' for
;; all files and "compiled" subdirs, `exists' for the base-dir) ;; all files and "compiled" subdirs, `exists' for the base-dir)
@ -220,10 +220,10 @@
(let loop ([paths paths] [bases '()]) (let loop ([paths paths] [bases '()])
(if (null? paths) (if (null? paths)
(reverse bases) (reverse bases)
(let-values ([(base name dir?) (split-path (car paths))]) (let-values ([(base* name dir?) (split-path (car paths))])
(let ([base (simplify-path* base)]) (define base (simplify-path* base*))
(loop (cdr paths) (loop (cdr paths)
(if (member base bases) bases (cons base bases)))))))) (if (member base bases) bases (cons base bases)))))))
(append (map (lambda (p) `(read-bytecode ,p)) paths) (append (map (lambda (p) `(read-bytecode ,p)) paths)
(map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases) (map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases)
(map (lambda (b) `(exists ,b)) bases))) (map (lambda (b) `(exists ,b)) bases)))
@ -256,25 +256,25 @@
[(null? todo) r] [(null? todo) r]
[(member (car todo) r) (loop (cdr todo) r)] [(member (car todo) r) (loop (cdr todo) r)]
[else [else
(let ([path (car todo)]) (define path (car todo))
(loop (append (cdr todo) (loop (append (cdr todo)
(filter-map (filter-map
(lambda (i) (lambda (i)
(simplify-path* (resolve-module-path-index i path))) (simplify-path* (resolve-module-path-index i path)))
(filter (lambda (i) (filter (lambda (i)
(and (module-path-index? i) (not (lib? i)))) (and (module-path-index? i) (not (lib? i))))
(append-map cdr (let ([m (get-module-code (append-map cdr (let ([m (get-module-code
path path
#:extension-handler #:extension-handler
(lambda (path loader?) #f))]) (lambda (path loader?) #f))])
(if m (if m
(module-compiled-imports m) (module-compiled-imports m)
null)))))) null))))))
(let ([l (cons path r)]) (let ([l (cons path r)])
;; If we need an .rkt path, also allow access to .ss path ;; If we need an .rkt path, also allow access to .ss path
(if (regexp-match? #rx#"[.]rkt$" (path->bytes path)) (if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
(cons (path-replace-suffix path #".ss") l) (cons (path-replace-suffix path #".ss") l)
l))))]))) l)))])))
;; Resources ---------------------------------------------------------------- ;; Resources ----------------------------------------------------------------
@ -289,30 +289,30 @@
thunk thunk
[kill (lambda () (kill-thread (current-thread)))] [kill (lambda () (kill-thread (current-thread)))]
[shutdown (lambda () (custodian-shutdown-all (current-custodian)))]) [shutdown (lambda () (custodian-shutdown-all (current-custodian)))])
(let* ([p #f] (define p #f)
[c (make-custodian (current-custodian))] (define c (make-custodian (current-custodian)))
[b (make-custodian-box c #t)] (define b (make-custodian-box c #t))
[break? (break-enabled)]) (define break? (break-enabled))
(parameterize-break #f (parameterize-break #f
(with-handlers ([(lambda (_) (not p)) (with-handlers ([(lambda (_) (not p))
;; if the after thunk was not called, then this error is ;; if the after thunk was not called, then this error is
;; about the thread dying unnaturally, so propagate ;; about the thread dying unnaturally, so propagate
;; whatever it did ;; whatever it did
(lambda (_) (lambda (_)
((if (custodian-box-value b) kill shutdown)))]) ((if (custodian-box-value b) kill shutdown)))])
(dynamic-wind void (dynamic-wind void
(lambda () (lambda ()
(parameterize ([current-custodian c]) (parameterize ([current-custodian c])
(call-in-nested-thread (call-in-nested-thread
(lambda () (lambda ()
(break-enabled break?) (break-enabled break?)
(dynamic-wind void thunk (dynamic-wind void thunk
;; this should always be called unless the thread is killed ;; this should always be called unless the thread is killed
;; or the custodian is shutdown, distinguish the two cases ;; or the custodian is shutdown, distinguish the two cases
;; through the above box ;; through the above box
(lambda () (lambda ()
(set! p (current-preserved-thread-cell-values)))))))) (set! p (current-preserved-thread-cell-values))))))))
(lambda () (when p (current-preserved-thread-cell-values p)))))))) (lambda () (when p (current-preserved-thread-cell-values p)))))))
;; useful wrapper around the above: run thunk, return one of: ;; useful wrapper around the above: run thunk, return one of:
;; - (list values val ...) ;; - (list values val ...)
@ -344,10 +344,10 @@
(lambda () (lambda ()
;; time limit ;; time limit
(when sec (when sec
(let ([t (current-thread)]) (define t (current-thread))
(thread (lambda () (thread (lambda ()
(unless (sync/timeout sec t) (set! timeout? #t)) (unless (sync/timeout sec t) (set! timeout? #t))
(kill-thread t))))) (kill-thread t))))
(thunk))) (thunk)))
(nested thunk)))) (nested thunk))))
(cond [timeout? (set! r 'time)] (cond [timeout? (set! r 'time)]
@ -374,23 +374,24 @@
;; other resource utilities ;; other resource utilities
(define (call-with-custodian-shutdown thunk) (define (call-with-custodian-shutdown thunk)
(let* ([cust (make-custodian (current-custodian))] (define cust (make-custodian (current-custodian)))
[r (parameterize ([current-custodian cust]) (nested thunk))]) (define r (parameterize ([current-custodian cust]) (nested thunk)))
(case r (case r
[(kill) (kill-thread (current-thread))] [(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))] [(shut) (custodian-shutdown-all (current-custodian))]
[else (apply (car r) (cdr r))]))) [else (apply (car r) (cdr r))]))
(define (call-with-killing-threads thunk) (define (call-with-killing-threads thunk)
(let* ([cur (current-custodian)] [sub (make-custodian cur)]) (define cur (current-custodian))
(define r (parameterize ([current-custodian sub]) (nested thunk))) (define sub (make-custodian cur))
(let kill-all ([x sub]) (define r (parameterize ([current-custodian sub]) (nested thunk)))
(cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))] (let kill-all ([x sub])
[(thread? x) (kill-thread x)])) (cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))]
(case r [(thread? x) (kill-thread x)]))
[(kill) (kill-thread (current-thread))] (case r
[(shut) (custodian-shutdown-all (current-custodian))] [(kill) (kill-thread (current-thread))]
[else (apply (car r) (cdr r))]))) [(shut) (custodian-shutdown-all (current-custodian))]
[else (apply (car r) (cdr r))]))
(define sandbox-eval-handlers (define sandbox-eval-handlers
(make-parameter (list #f call-with-custodian-shutdown))) (make-parameter (list #f call-with-custodian-shutdown)))
@ -404,25 +405,23 @@
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
(define (make-evaluation-namespace) (define (make-evaluation-namespace)
(let* ([specs (sandbox-namespace-specs)] (define specs (sandbox-namespace-specs))
[new-ns ((car specs))] (define new-ns ((car specs)))
[orig-ns (namespace-anchor->empty-namespace anchor)] (define orig-ns (namespace-anchor->empty-namespace anchor))
[mods (cdr specs)]) (define mods (cdr specs))
(parameterize ([current-namespace orig-ns]) (parameterize ([current-namespace orig-ns])
(for ([mod (in-list mods)]) (dynamic-require mod #f))) (for ([mod (in-list mods)]) (dynamic-require mod #f)))
(parameterize ([current-namespace new-ns]) (parameterize ([current-namespace new-ns])
(for ([mod (in-list mods)]) (namespace-attach-module orig-ns mod))) (for ([mod (in-list mods)]) (namespace-attach-module orig-ns mod)))
new-ns)) new-ns)
(define (extract-required language requires) (define (extract-required language requires)
(let* ([requires (cond [(string? language) (cons language requires)] (cond
[(not (pair? language)) requires] [(string? language) (cons language requires)]
[(memq (car language) '(lib file planet quote)) [(not (pair? language)) requires]
(cons language requires)] [(memq (car language) '(lib file planet quote)) (cons language requires)]
[(eq? (car language) 'begin) requires] [(eq? (car language) 'begin) requires]
[else (error 'extract-required [else (error 'extract-required "bad language spec: ~e" language)]))
"bad language spec: ~e" language)])])
requires))
(define (input->port inp) (define (input->port inp)
;; returns #f when it can't create a port ;; returns #f when it can't create a port
@ -442,18 +441,18 @@
(let ([p (input->port (car inps))]) (let ([p (input->port (car inps))])
(cond [(and p (null? (cdr inps))) (cond [(and p (null? (cdr inps)))
(port-count-lines! p) (port-count-lines! p)
(let ([source (or (object-name p) (define source
;; just in case someone uses a function as the (or (object-name p)
;; source... ;; just in case someone uses a function as the source...
(if (procedure? source) (if (procedure? source)
(lambda (x) (eq? x source)) (lambda (x) (eq? x source))
source))]) source)))
(parameterize ([current-input-port p] (parameterize ([current-input-port p]
;; [read-accept-reader #t] is this needed? ;; [read-accept-reader #t] is this needed?
[read-accept-lang accept-lang?]) [read-accept-lang accept-lang?])
(begin0 (values ((sandbox-reader) source) source) (begin0 (values ((sandbox-reader) source) source)
;; close a port if we opened it ;; close a port if we opened it
(unless (eq? p (car inps)) (close-input-port p)))))] (unless (eq? p (car inps)) (close-input-port p))))]
[p (error 'input->code "ambiguous inputs: ~e" inps)] [p (error 'input->code "ambiguous inputs: ~e" inps)]
[(andmap syntax? inps) [(andmap syntax? inps)
(values inps (values inps
@ -499,10 +498,10 @@
(read-case-sensitive #t) (read-case-sensitive #t)
(read-decimal-as-inexact #f) (read-decimal-as-inexact #f)
;; needed to make the test-engine work ;; needed to make the test-engine work
(let ([orig-ns (namespace-anchor->empty-namespace anchor)]) (define orig-ns (namespace-anchor->empty-namespace anchor))
(parameterize ([current-namespace orig-ns]) (parameterize ([current-namespace orig-ns])
(dynamic-require 'racket/class #f)) (dynamic-require 'racket/class #f))
(namespace-attach-module orig-ns 'racket/class))])) (namespace-attach-module orig-ns 'racket/class)]))
;; Returns a single (module ...) or (begin ...) expression (a `begin' list will ;; Returns a single (module ...) or (begin ...) expression (a `begin' list will
;; be evaluated one by one -- the language might not have a `begin'), and a ;; be evaluated one by one -- the language might not have a `begin'), and a
@ -574,31 +573,32 @@
(when uncovered! (when uncovered!
(parameterize ([current-code-inspector orig-code-inspector]) (parameterize ([current-code-inspector orig-code-inspector])
(eval `(,#'#%require racket/private/sandbox-coverage)))) (eval `(,#'#%require racket/private/sandbox-coverage))))
(let ([ns (syntax-case* program (module) literal-identifier=? (define ns
[(module mod . body) (syntax-case* program (module) literal-identifier=?
(identifier? #'mod) [(module mod . body)
(let ([mod #'mod]) (identifier? #'mod)
(lambda () (let ([mod #'mod])
(eval `(,#'require (quote ,mod))) (lambda ()
(module->namespace `(quote ,(syntax-e mod)))))] (eval `(,#'require (quote ,mod)))
[_else #f])]) (module->namespace `(quote ,(syntax-e mod)))))]
;; the actual evaluation happens under the specified limits [_else #f]))
(parameterize ([current-load-relative-directory ;; the actual evaluation happens under the specified limits
(let* ([d (and (syntax? program) (syntax-source program))] (parameterize ([current-load-relative-directory
[d (and (path-string? d) (path-only d))]) (let* ([d (and (syntax? program) (syntax-source program))]
(if (and d (directory-exists? d)) [d (and (path-string? d) (path-only d))])
d (if (and d (directory-exists? d))
(current-load-relative-directory)))]) d
((limit-thunk (lambda () (current-load-relative-directory)))])
(if (and (pair? program) (eq? 'begin (car program))) ((limit-thunk (lambda ()
(eval* (cdr program)) (if (and (pair? program) (eq? 'begin (car program)))
(eval program)) (eval* (cdr program))
(when ns (set! ns (ns))))))) (eval program))
(when uncovered! (when ns (set! ns (ns)))))))
(let ([get (let ([ns (current-namespace)]) (when uncovered!
(lambda () (eval '(get-uncovered-expressions) ns)))]) (define get (let ([ns (current-namespace)])
(uncovered! (list (get) get)))) (lambda () (eval '(get-uncovered-expressions) ns))))
(when (namespace? ns) (current-namespace ns)))) (uncovered! (list (get) get)))
(when (namespace? ns) (current-namespace ns)))
(define current-eventspace (mz/mr (make-parameter #f) current-eventspace)) (define current-eventspace (mz/mr (make-parameter #f) current-eventspace))
(define make-eventspace (mz/mr void make-eventspace)) (define make-eventspace (mz/mr void make-eventspace))
@ -673,9 +673,9 @@
(define terminated? #f) ; set to an exception value when the sandbox dies (define terminated? #f) ; set to an exception value when the sandbox dies
(define breaks-originally-enabled? (break-enabled)) (define breaks-originally-enabled? (break-enabled))
(define (limit-thunk thunk) (define (limit-thunk thunk)
(let* ([sec (and limits (car limits))] (define sec (and limits (car limits)))
[mb (and limits (cadr limits))] (define mb (and limits (cadr limits)))
[thunk (if (or sec mb) (let* ([thunk (if (or sec mb)
(lambda () (call-with-limits sec mb thunk)) (lambda () (call-with-limits sec mb thunk))
thunk)] thunk)]
[thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)]) [thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)])
@ -697,11 +697,11 @@
[else "internal error: cannot guess termination reason"]))))) [else "internal error: cannot guess termination reason"])))))
(define (user-kill) (define (user-kill)
(when user-thread (when user-thread
(let ([t user-thread]) (define t user-thread)
(set! user-thread #f) (set! user-thread #f)
(terminated! #f) (terminated! #f)
(custodian-shutdown-all user-cust) (custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case (kill-thread t)) ; just in case
(void)) (void))
(define (terminate+kill! reason raise?) (define (terminate+kill! reason raise?)
(terminated! reason) (terminated! reason)
@ -710,58 +710,56 @@
(define (user-break) (define (user-break)
(when user-thread (break-thread user-thread))) (when user-thread (break-thread user-thread)))
(define (user-process) (define (user-process)
(let ([break-paramz (current-break-parameterization)]) (define break-paramz (current-break-parameterization))
(parameterize-break (parameterize-break
#f ;; disable breaks during administrative work #f ;; disable breaks during administrative work
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) (with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
(call-with-break-parameterization (call-with-break-parameterization
break-paramz break-paramz
(lambda () (lambda ()
;; enable breaks, maybe ;; enable breaks, maybe
(when breaks-originally-enabled? (break-enabled #t)) (when breaks-originally-enabled? (break-enabled #t))
;; first set up the environment ;; first set up the environment
(init-hook) (init-hook)
((sandbox-init-hook)) ((sandbox-init-hook))
;; now read and evaluate the input program (in the user context) ;; now read and evaluate the input program (in the user context)
(evaluate-program (evaluate-program
(let-values ([(prog src) (program-maker)]) (let-values ([(prog src) (program-maker)])
(when coverage? (set! default-coverage-source-filter src)) (when coverage? (set! default-coverage-source-filter src))
prog) prog)
limit-thunk limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get)))))) (and coverage? (lambda (es+get) (set! uncovered es+get))))))
(channel-put result-ch 'ok)) (channel-put result-ch 'ok))
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions ;; finally wait for interaction expressions
(let ([n 0]) (define n 0)
(let loop () (let loop ()
(let ([expr (channel-get input-ch)]) (define expr (channel-get input-ch))
(when (eof-object? expr) (when (eof-object? expr)
(terminated! 'eof) (channel-put result-ch expr) (user-kill)) (terminated! 'eof) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))]) (channel-put result-ch (cons 'exn exn)))])
(define run (define run
(if (evaluator-message? expr) (if (evaluator-message? expr)
(case (evaluator-message-msg expr) (case (evaluator-message-msg expr)
[(thunk) (limit-thunk [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
(car (evaluator-message-args expr)))] [(thunk*) (car (evaluator-message-args expr))]
[(thunk*) (car (evaluator-message-args expr))] [else (error 'sandbox "internal error (bad message)")])
[else (error 'sandbox "internal error (bad message)")]) (limit-thunk
(limit-thunk (lambda ()
(lambda () (set! n (add1 n))
(set! n (add1 n)) (define exprs
(define exprs (let-values ([(code _)
(let-values ([(code _) (input->code (list expr) 'eval n #f)])
(input->code (list expr) 'eval n #f)]) code))
code)) (eval* (map (lambda (expr) (cons '#%top-interaction expr))
(eval* (map (lambda (expr) exprs))))))
(cons '#%top-interaction expr)) (channel-put result-ch
exprs)))))) (cons 'vals
(channel-put result-ch (call-with-break-parameterization
(cons 'vals break-paramz
(call-with-break-parameterization (lambda () (call-with-values run list))))))
break-paramz (loop))))
(lambda () (call-with-values run list))))))
(loop)))))))
(define (get-user-result) (define (get-user-result)
(if (and (sandbox-propagate-breaks) (if (and (sandbox-propagate-breaks)
;; The following test is weird. We reliably catch breaks if breaks ;; The following test is weird. We reliably catch breaks if breaks
@ -798,23 +796,23 @@
[(not (sync/timeout 0 busy-sema)) [(not (sync/timeout 0 busy-sema))
(error 'evaluator "nested evaluator call with: ~e" expr)] (error 'evaluator "nested evaluator call with: ~e" expr)]
[else (channel-put input-ch expr) [else (channel-put input-ch expr)
(let ([r (get-user-result)]) (define r (get-user-result))
(semaphore-post busy-sema) (semaphore-post busy-sema)
(cond [(eof-object? r) (terminate+kill! #t #t)] (cond [(eof-object? r) (terminate+kill! #t #t)]
[(eq? (car r) 'exn) (raise (cdr r))] [(eq? (car r) 'exn) (raise (cdr r))]
[else (apply values (cdr r))]))])) [else (apply values (cdr r))])]))
(define (get-uncovered [prog? #t] [src default-coverage-source-filter]) (define (get-uncovered [prog? #t] [src default-coverage-source-filter])
(unless uncovered (unless uncovered
(error 'get-uncovered-expressions "no coverage information")) (error 'get-uncovered-expressions "no coverage information"))
(let ([uncovered (if prog? (car uncovered) ((cadr uncovered)))]) (define uncovered (if prog? (car uncovered) ((cadr uncovered))))
(if src (if src
;; when given a list of syntaxes, the src is actually a function that ;; when given a list of syntaxes, the src is actually a function that
;; checks the input source value (which does a union of the sources) ;; checks the input source value (which does a union of the sources)
(filter (if (procedure? src) (filter (if (procedure? src)
(lambda (x) (src (syntax-source x))) (lambda (x) (src (syntax-source x)))
(lambda (x) (equal? src (syntax-source x)))) (lambda (x) (equal? src (syntax-source x))))
uncovered) uncovered)
uncovered))) uncovered))
(define (output-getter p) (define (output-getter p)
(if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p)) (if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p))
(define (input-putter [arg input]) (define (input-putter [arg input])
@ -847,18 +845,19 @@
[(output-port? out) out] [(output-port? out) out]
[(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)] [(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)]
[(memq out '(bytes string)) [(memq out '(bytes string))
(let* ([bytes? (eq? out 'bytes)] (define bytes? (eq? out 'bytes))
;; create the port under the user's custodian ;; create the port under the user's custodian
[out (parameterize ([current-custodian user-cust]) (define out
(call-in-nested-thread (parameterize ([current-custodian user-cust])
;; this doesn't really matter: they're the same anyway (call-in-nested-thread
(if bytes? open-output-bytes open-output-string)))]) ;; this doesn't really matter: they're the same anyway
(set-out! (if bytes? open-output-bytes open-output-string))))
(lambda () (set-out!
;; this will run in the user context (lambda ()
(let ([buf (get-output-bytes out #t)]) ;; this will run in the user context
(if bytes? buf (bytes->string/utf-8 buf #\?))))) (define buf (get-output-bytes out #t))
out)] (if bytes? buf (bytes->string/utf-8 buf #\?))))
out]
[else (error who "bad sandox-~a spec: ~e" what out)])) [else (error who "bad sandox-~a spec: ~e" what out)]))
;; set global memory limit ;; set global memory limit
(when (and memory-accounting? (sandbox-memory-limit)) (when (and memory-accounting? (sandbox-memory-limit))
@ -935,37 +934,36 @@
[current-eventspace (parameterize-break [current-eventspace (parameterize-break
#f #f
(make-eventspace))]) (make-eventspace))])
(let ([t (bg-run->thread (run-in-bg user-process))]) (define t (bg-run->thread (run-in-bg user-process)))
(set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t)))) (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))
(set! user-thread t))) (set! user-thread t))
(let ([r (get-user-result)]) (define r (get-user-result))
(if (eq? r 'ok) (if (eq? r 'ok)
;; initial program executed ok, so return an evaluator ;; initial program executed ok, so return an evaluator
evaluator evaluator
;; program didn't execute ;; program didn't execute
(raise r)))) (raise r)))
(define (make-evaluator language (define (make-evaluator lang
#:requires [requires null] #:allow-read [allow null] #:requires [requires null] #:allow-read [allow null]
. input-program) . input-program)
;; `input-program' is either a single argument specifying a file/string, or ;; `input-program' is either a single argument specifying a file/string, or
;; multiple arguments for a sequence of expressions ;; multiple arguments for a sequence of expressions
(let (;; make it possible to provide #f for no language and no requires ;; make it possible to use simple paths to files to require
[lang language] (define reqs
;; make it possible to use simple paths to files to require (if (not (list? requires))
[reqs (if (not (list? requires)) (error 'make-evaluator "bad requires: ~e" requires)
(error 'make-evaluator "bad requires: ~e" requires) (map (lambda (r)
(map (lambda (r) (if (or (pair? r) (symbol? r))
(if (or (pair? r) (symbol? r)) r
r `(file ,(path->string (simplify-path* r)))))
`(file ,(path->string (simplify-path* r))))) requires)))
requires))]) (make-evaluator* 'make-evaluator
(make-evaluator* 'make-evaluator (init-hook-for-language lang)
(init-hook-for-language lang) (append (extract-required (or (decode-language lang) lang)
(append (extract-required (or (decode-language lang) lang) reqs)
reqs) allow)
allow) (lambda () (build-program lang reqs input-program))))
(lambda () (build-program lang reqs input-program)))))
(define (make-module-evaluator (define (make-module-evaluator
input-program #:allow-read [allow null] #:language [reqlang #f]) input-program #:allow-read [allow null] #:language [reqlang #f])