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

Sandboxes make up and remember a reasonable default source to filter

Browse Source 
uncovered expressions on.

(See http://lists.racket-lang.org/users/archive/2010-October/042008.html
for a detailed description.)
This commit is contained in:
Eli Barzilay 2010-10-08 16:02:26 -04:00
parent c4b590d9bf
commit 40ecda1a77
2 changed files with 69 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/racket/sandbox.rkt
View File

@ -439,23 +439,37 @@
[(path? inp) (open-input-file inp)] [(path? inp) (open-input-file inp)]
[else #f])) [else #f]))
;; Gets an input spec returns a list of syntaxes. The input can be a list of ;; Gets an input spec returns a list of syntaxes and a default source to filter
;; sexprs/syntaxes, or a list with a single input port spec ;; uncovered expressions with. The input can be a list of sexprs/syntaxes, or
;; (path/string/bytes) value. ;; a list with a single input port spec (path/string/bytes) value. Note that
;; the source can be a filtering function.
(define (input->code inps source n) (define (input->code inps source n)
(if (null? inps) (if (null? inps)
'() (values '() source)
(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)
;; just in case someone uses a function as the
;; source...
(if (procedure? source)
(lambda (x) (eq? x source))
source))])
(parameterize ([current-input-port p]) (parameterize ([current-input-port p])
(begin0 ((sandbox-reader) (or (object-name p) 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)
(values inps
(let ([srcs (remove-duplicates (map syntax-source inps)
equal?)])
(if (null? (cdr srcs))
(car srcs)
(lambda (x) (memq x srcs)))))]
[else (let loop ([inps inps] [n n] [r '()]) [else (let loop ([inps inps] [n n] [r '()])
(if (null? inps) (if (null? inps)
(reverse r) (values (reverse r) source)
(loop (cdr inps) (and n (add1 n)) (loop (cdr inps) (and n (add1 n))
;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc ;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc
;; (starting from the `n' argument) ;; (starting from the `n' argument)
@ -482,8 +496,9 @@
(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 ;; Returns a single (module ...) or (begin ...) expression (a `begin' list will
;; will be evaluated one by one -- the language might not have a `begin'). ;; be evaluated one by one -- the language might not have a `begin'), and a
;; default source to filter uncovered expressions with.
;; ;;
;; FIXME: inserting `#%require's here is bad if the language has a ;; FIXME: inserting `#%require's here is bad if the language has a
;; `#%module-begin' that processes top-level forms specially. ;; `#%module-begin' that processes top-level forms specially.
@ -494,16 +509,19 @@
;; it comes from `#%kernel', so it's always present through ;; it comes from `#%kernel', so it's always present through
;; transitive requires. ;; transitive requires.
(define (build-program language requires input-program) (define (build-program language requires input-program)
(define-values (prog-stxs source) (input->code input-program 'program 1))
(let* ([body (append (if (and (pair? requires) (eq? 'begin (car requires))) (let* ([body (append (if (and (pair? requires) (eq? 'begin (car requires)))
(cdr requires) (cdr requires)
(map (lambda (r) (list #'#%require r)) requires)) (map (lambda (r) (list #'#%require r)) requires))
(input->code input-program 'program 1))] prog-stxs)]
[use-lang (lambda (lang) `(module program ,lang . ,body))]) [use-lang (lambda (lang) `(module program ,lang . ,body))])
(cond [(decode-language language) => use-lang] (values (cond [(decode-language language) => use-lang]
[(module-path? language) (use-lang language)] [(module-path? language) (use-lang language)]
[(and (list? language) (eq? 'begin (car language))) [(and (list? language) (eq? 'begin (car language)))
(append language body)] (append language body)]
[else (error 'make-evaluator "bad language spec: ~e" language)]))) [else (error 'make-evaluator "bad language spec: ~e"
language)])
source)))
(define (decode-language language) (define (decode-language language)
(cond [(and (list? language) (cond [(and (list? language)
@ -630,6 +648,7 @@
(define user-cust-box (make-custodian-box user-cust #t)) (define user-cust-box (make-custodian-box user-cust #t))
(define coverage? (sandbox-coverage-enabled)) (define coverage? (sandbox-coverage-enabled))
(define uncovered #f) (define uncovered #f)
(define default-coverage-source-filter #f)
(define input-ch (make-channel)) (define input-ch (make-channel))
(define result-ch (make-channel)) (define result-ch (make-channel))
(define busy-sema (make-semaphore 1)) (define busy-sema (make-semaphore 1))
@ -692,9 +711,11 @@
;; 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 ;; now read and evaluate the input program (in the user context)
(evaluate-program (evaluate-program
(if (procedure? program-maker) (program-maker) program-maker) (let-values ([(prog src) (program-maker)])
(when coverage? (set! default-coverage-source-filter src))
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))
@ -710,19 +731,24 @@
(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 (car (evaluator-message-args expr)))] [(thunk) (limit-thunk
(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))
(eval* (map (lambda (expr) (cons '#%top-interaction expr)) (eval* (map (lambda (expr)
(input->code (list expr) 'eval n))))))) (cons '#%top-interaction expr))
(channel-put result-ch (cons 'vals (let-values ([(code _)
(input->code (list expr)
'eval n)])
code)))))))
(channel-put result-ch
(cons 'vals
(call-with-break-parameterization (call-with-break-parameterization
break-paramz break-paramz
(lambda () (lambda () (call-with-values run list))))))
(call-with-values run list))))))
(loop))))))) (loop)))))))
(define (get-user-result) (define (get-user-result)
(if (and (sandbox-propagate-breaks) (if (and (sandbox-propagate-breaks)
@ -765,12 +791,17 @@
(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 'program]) (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)))]) (let ([uncovered (if prog? (car uncovered) ((cadr uncovered)))])
(if src (if src
(filter (lambda (x) (equal? src (syntax-source x))) uncovered) ;; 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)
(filter (if (procedure? src)
(lambda (x) (src (syntax-source x)))
(lambda (x) (equal? src (syntax-source x))))
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))
@ -926,7 +957,8 @@
input-program #:allow-read [allow null] #:language [reqlang #f]) input-program #:allow-read [allow null] #:language [reqlang #f])
;; this is for a complete module input program ;; this is for a complete module input program
(define (make-program) (define (make-program)
(let ([prog (input->code (list input-program) 'program #f)]) (let-values ([(prog source)
(input->code (list input-program) 'program #f)])
(unless (= 1 (length prog)) (unless (= 1 (length prog))
(error 'make-evaluator "expecting a single `module' program; ~a" (error 'make-evaluator "expecting a single `module' program; ~a"
(if (zero? (length prog)) (if (zero? (length prog))
@ -935,7 +967,7 @@
(syntax-case* (car prog) (module) literal-identifier=? (syntax-case* (car prog) (module) literal-identifier=?
[(module modname lang body ...) [(module modname lang body ...)
(if (or (not reqlang) (equal? reqlang (syntax->datum #'lang))) (if (or (not reqlang) (equal? reqlang (syntax->datum #'lang)))
(car prog) (values (car prog) source)
(error 'make-evaluator (error 'make-evaluator
"module code used `~e' for a language, expecting `~e'" "module code used `~e' for a language, expecting `~e'"
(syntax->datum #'lang) reqlang))] (syntax->datum #'lang) reqlang))]

12
collects/scribblings/reference/sandbox.scrbl
View File

@ -806,7 +806,7 @@ in a way that depends on the setting of @racket[(sandbox-output)] or
@defproc[(get-uncovered-expressions [evaluator (any/c . -> . any)] @defproc[(get-uncovered-expressions [evaluator (any/c . -> . any)]
[prog? any/c #t] [prog? any/c #t]
[src any/c 'program]) [src any/c _default-src])
(listof syntax?)]{ (listof syntax?)]{
Retrieves uncovered expression from an evaluator, as longs as the Retrieves uncovered expression from an evaluator, as longs as the
@ -828,11 +828,11 @@ program to ensure that your tests cover the whole code.
The second optional argument, @racket[src], specifies that the result The second optional argument, @racket[src], specifies that the result
should be filtered to hold only @tech{syntax objects} whose source should be filtered to hold only @tech{syntax objects} whose source
matches @racket[src]. The default, @racket['program], is the source matches @racket[src]. The default is the source that was used in the
associated with the input program by the default program code, if there was one. Note that @racket['program] is used as
@racket[sandbox-reader]---which provides only @tech{syntax objects} the source value if the input program was given as S-expressions or as a
from the input program (and not from required modules or expressions string (and in these cases it will be the default for filtering). If given
that were passed to the evaluator). A @racket[#f] avoids filtering. @racket[#f], the result is the unfiltered list of expressions.
The resulting list of @tech{syntax objects} has at most one expression The resulting list of @tech{syntax objects} has at most one expression
for each position and span. Thus, the contents may be unreliable, but for each position and span. Thus, the contents may be unreliable, but