From 926ff4fbb0af8f5bd689184a1c94952782e77e9f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 6 Jan 2008 16:54:34 +0000 Subject: [PATCH] sandbox Scribble evaluations; fix rational exact->inexact loss of precision svn: r8238 original commit: f3cb86dc1ac569297d67573dc73b7f5e3859656a --- collects/scribble/eval.ss | 181 +++++++++++++-------- collects/scribblings/scribble/eval.scrbl | 106 ++++++++---- collects/scribblings/scribble/reader.scrbl | 5 + 3 files changed, 192 insertions(+), 100 deletions(-) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index fb2dc723..28663614 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -5,6 +5,7 @@ "scheme.ss" "decode.ss" scheme/file + scheme/sandbox mzlib/string (for-syntax scheme/base)) @@ -20,14 +21,14 @@ defexamples defexamples* as-examples - - current-int-namespace - eval-example-string + + make-base-eval scribble-eval-handler) - (define current-int-namespace (make-parameter (current-namespace))) - (define scribble-eval-handler (make-parameter (lambda (c? x) (eval x)))) + (define scribble-eval-handler (make-parameter + (lambda (ev c? x) + (ev x)))) (define image-counter 0) @@ -123,27 +124,23 @@ (cdr val-list+outputs) #f))))))) - (define (do-eval s) + (define ((do-eval ev) s) (syntax-case s (code:comment eval:alts) [(code:line v (code:comment . rest)) - (do-eval #'v)] + ((do-eval ev) #'v)] [(code:comment . rest) (list (list (void)) "" "")] [(eval:alts p e) - (do-eval #'e)] + ((do-eval ev) #'e)] [else - (let ([o (open-output-string)] - [o2 (open-output-string)]) - (parameterize ([current-output-port o] - [current-error-port o2]) - (with-handlers ([exn? (lambda (e) - (list (exn-message e) - (get-output-string o) - (get-output-string o2)))]) - (list (let ([v (do-plain-eval s #t)]) - (make-reader-graph (copy-value v (make-hash-table)))) - (get-output-string o) - (get-output-string o2)))))])) + (with-handlers ([exn? (lambda (e) + (list (exn-message e) + (get-output ev) + (get-error-output ev)))]) + (list (let ([v (do-plain-eval ev s #t)]) + (make-reader-graph (copy-value v (make-hash-table)))) + (get-output ev) + (get-error-output ev)))])) (define (install ht v v2) (hash-table-put! ht v v2) @@ -184,64 +181,78 @@ [else v])) (define (strip-comments stx) - (syntax-case stx (code:comment code:blank) - [((code:comment . _) . rest) - (strip-comments #'rest)] - [(a . b) + (cond + [(syntax? stx) (datum->syntax stx - (cons (strip-comments #'a) - (strip-comments #'b)) + (strip-comments (syntax-e stx)) stx stx stx)] - [code:blank #'(void)] - [else stx])) - + [(pair? stx) + (let ([a (car stx)] + [comment? (lambda (a) + (and (pair? a) + (or (eq? (car a) 'code:comment) + (and (identifier? a) + (eq? (syntax-e (car a)) 'code:comment)))))]) + (if (or (comment? a) + (and (syntax? a) (comment? (syntax-e a)))) + (strip-comments (cdr stx)) + (cons (strip-comments a) + (strip-comments (cdr stx)))))] + [(eq? stx 'code:blank) (void)] + [else stx])) - (define (do-plain-eval s catching-exns?) - (parameterize ([current-namespace (current-int-namespace)]) - (call-with-values (lambda () - ((scribble-eval-handler) - catching-exns? - (let ([s (strip-comments s)]) + (define (make-base-eval) + (parameterize ([sandbox-security-guard (current-security-guard)] + [sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f] + [sandbox-make-inspector current-inspector]) + (make-evaluator 'scheme/base))) + + (define (do-plain-eval ev s catching-exns?) + (call-with-values (lambda () + ((scribble-eval-handler) + ev + catching-exns? + (let ([s (strip-comments s)]) + (if (syntax? s) (syntax-case s (module) [(module . _rest) (syntax->datum s)] - [_else s])))) - list))) + [_else s]) + s)))) + list)) + + (define-syntax-rule (quote-expr e) 'e) + + (define (do-interaction-eval ev e) + (parameterize ([current-command-line-arguments #()]) + (do-plain-eval (or ev (make-base-eval)) e #f)) + "") (define-syntax interaction-eval (syntax-rules () - [(_ e) (#%expression - (begin (parameterize ([current-command-line-arguments #()]) - (do-plain-eval (quote-syntax e) #f)) - ""))])) + [(_ #:eval ev e) (do-interaction-eval ev (quote-expr e))] + [(_ e) (do-interaction-eval #f (quote-expr e))])) (define (show-val v) (span-class "schemeresult" (to-element/no-color v))) + (define (do-interaction-eval-show ev e) + (parameterize ([current-command-line-arguments #()]) + (show-val (car (do-plain-eval (or ev (make-base-eval)) e #f))))) + (define-syntax interaction-eval-show (syntax-rules () - [(_ e) (#%expression - (parameterize ([current-command-line-arguments #()]) - (show-val (car (do-plain-eval (quote-syntax e) #f)))))])) - - (define (eval-example-string s) - (eval (read (open-input-string s)))) - - (parameterize ([current-namespace (current-int-namespace)]) - (eval `(define eval-example-string ,eval-example-string))) + [(_ #:eval ev e) (do-interaction-eval-show ev (quote-expr e))] + [(_ e) (do-interaction-eval-show #f (quote-expr e))])) (define-syntax schemeinput* - (syntax-rules (eval-example-string eval:alts code:comment) - [(_ (eval-example-string s)) - (make-paragraph - (list - (hspace 2) - (tt "> ") - (span-class "schemevalue" (schemefont s))))] + (syntax-rules (eval:alts code:comment) [(_ (code:comment . rest)) (schemeblock (code:comment . rest))] [(_ (eval:alts a b)) (schemeinput* a)] [(_ e) (schemeinput e)])) @@ -266,61 +277,87 @@ [(_ (code:line (define . rest) . rest2)) (syntax-case stx () [(_ e) #'(schemeblock+line e)])] - [(_ e) #'(schemeinput e)])) + [(_ e) #'(schemeinput* e)])) + + (define (do-titled-interaction ev t shows evals) + (interleave t + shows + (map (do-eval ev) evals))) (define-syntax titled-interaction (syntax-rules () + [(_ #:eval ev t schemeinput* e ...) + (do-titled-interaction ev t (list (schemeinput* e) ...) (list (quote-expr e) ...))] [(_ t schemeinput* e ...) - (interleave t - (list (schemeinput* e) ...) - (map do-eval (list (quote-syntax e) ...)))])) + (titled-interaction #:eval (make-base-eval) t schemeinput* e ...)])) (define-syntax interaction (syntax-rules () + [(_ #:eval ev e ...) (titled-interaction #:eval ev #f schemeinput* e ...)] [(_ e ...) (titled-interaction #f schemeinput* e ...)])) (define-syntax schemeblock+eval (syntax-rules () + [(_ #:eval ev e ...) + (let ([eva ev]) + (#%expression + (begin (interaction-eval #:eval eva e) ... + (schemeblock e ...))))] [(_ e ...) - (#%expression - (begin (interaction-eval e) ... - (schemeblock e ...)))])) + (schemeblock+eval #:eval (make-base-eval) e ...)])) (define-syntax schememod+eval (syntax-rules () + [(_ #:eval ev name e ...) + (let ([eva ev]) + (#%expression + (begin (interaction-eval #:eval eva e) ... + (schememod name e ...))))] [(_ name e ...) - (#%expression - (begin (interaction-eval e) ... - (schememod name e ...)))])) + (schememod+eval #:eval (make-base-eval) name e ...)])) (define-syntax def+int (syntax-rules () - [(_ def e ...) - (make-splice (list (schemeblock+eval def) - (interaction e ...)))])) + [(_ #:eval ev def e ...) + (let ([eva ev]) + (make-splice (list (schemeblock+eval #:eval eva def) + (interaction #:eval eva e ...))))] + [(_ def e ...) + (def+int #:eval (make-base-eval) def e ...)])) (define-syntax defs+int (syntax-rules () + [(_ #:eval ev [def ...] e ...) + (let ([eva ev]) + (make-splice (list (schemeblock+eval #:eval eva def ...) + (interaction #:eval eva e ...))))] [(_ [def ...] e ...) - (make-splice (list (schemeblock+eval def ...) - (interaction e ...)))])) + (defs+int #:eval (make-base-eval) [def ...] e ...)])) (define example-title (make-paragraph (list "Examples:"))) (define-syntax examples (syntax-rules () + [(_ #:eval ev e ...) + (titled-interaction #:eval ev example-title schemeinput* e ...)] [(_ e ...) (titled-interaction example-title schemeinput* e ...)])) (define-syntax examples* (syntax-rules () + [(_ #:eval ev example-title e ...) + (titled-interaction #:eval ev example-title schemeinput* e ...)] [(_ example-title e ...) (titled-interaction example-title schemeinput* e ...)])) (define-syntax defexamples (syntax-rules () + [(_ #:eval ev e ...) + (titled-interaction #:eval ev example-title schemedefinput* e ...)] [(_ e ...) (titled-interaction example-title schemedefinput* e ...)])) (define-syntax defexamples* (syntax-rules () + [(_ #:eval ev example-title e ...) + (titled-interaction #:eval ev example-title schemedefinput* e ...)] [(_ example-title e ...) (titled-interaction example-title schemedefinput* e ...)])) diff --git a/collects/scribblings/scribble/eval.scrbl b/collects/scribblings/scribble/eval.scrbl index 2592e4e8..a0a4af9a 100644 --- a/collects/scribblings/scribble/eval.scrbl +++ b/collects/scribblings/scribble/eval.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc -@require[scribble/manual] -@require["utils.ss"] +@(require scribble/manual + "utils.ss" + (for-label scheme/sandbox)) @title[#:tag "eval"]{Evaluation and Examples} @@ -9,10 +10,19 @@ utilities for evaluating code at document-build time and incorporating the results in the document, especially to show example uses of defined procedures and syntax.} -@defform[(interaction datum ...)]{Like @scheme[schemeinput], except -that the result for each input @scheme[datum] is shown on the next -line. The result is determined by evaluating the syntax-quoted form of -the @scheme[datum]. +@defform*[[(interaction datum ...) + (interaction #:eval eval-expr datum ...)]]{ + +Like @scheme[schemeinput], except that the result for each input +@scheme[datum] is shown on the next line. The result is determined by +evaluating the @scheme[quote]d form of the @scheme[datum] using he +evaluator produced by @scheme[eval-expr], if provided. + +The @scheme[eval-expr] must produce a sandbox evaluator via +@scheme[make-evaluator] or @scheme[make-module-evaluator] with the +@scheme[sandbox-output] and @scheme[sandbox-error-output] parameters +set to @scheme['string]. If @scheme[eval] is not provided, an +evaluator is created using @scheme[make-base-eval]. Uses of @scheme[code:comment] and @schemeidfont{code:blank} are stipped from each @scheme[datum] before evaluation. @@ -25,33 +35,73 @@ If a datum has the form @scheme[(eval:alts #,(svar show-datum) #,(svar eval-datum))], then @svar[show-datum] is typeset, while @svar[eval-datum] is evaluated.} -@defform[(interaction-eval datum)]{Evaluates the syntax-quoted form of -each @scheme[datum] via @scheme[do-eval] and returns the empty string.} -@defform[(interaction-eval-show datum)]{Evaluates the syntax-quoted form of -@scheme[datum] and produces an element represeting the printed form of -the result.} +@defform*[[(interaction-eval datum) + (interaction-eval #:eval eval-expr datum)]]{ -@defform[(schemeblock+eval datum ...)]{Combines @scheme[schemeblock] -and @scheme[interaction-eval].} +Like @scheme[interaction], evaluates the @scheme[quote]d form of +@scheme[datum], but returns the empty string.} -@defform[(schememod+eval name datum ...)]{Combines @scheme[schememod] -and @scheme[interaction-eval].} -@defform[(def+int defn-datum expr-datum ...)]{Like -@scheme[interaction], except the the @scheme[defn-datum] is typeset as -for @scheme[schemeblock] (i.e., no prompt) with a line of space -between the definition and the interactions.} +@defform*[[(interaction-eval-show datum) + (interaction-eval-show #:eval eval-expr datum)]]{ -@defform[(defs+int (defn-datum ...) expr-datum ...)]{Like -@scheme[def+int], but for multiple leading definitions.} +Like @scheme[interaction-eval], but produces an element representing +the printed form of the evaluation result.} -@defform[(examples datum ...)]{Like @scheme[interaction], but with an -``Examples:'' label prefixed.} -@defform[(defexamples datum ...)]{Like @scheme[examples], but each -definition using @scheme[define] among the @scheme[datum]s is typeset -without a prompt, and with space after it.} +@defform*[[(schemeblock+eval datum ...) + (schemeblock+eval #:eval eval-expr datum ...)]]{ -@defthing[current-int-namespace parameter?]{A parameter to hold the -namespace used by @scheme[interaction], etc.} +Combines @scheme[schemeblock] and @scheme[interaction-eval].} + + +@defform*[[(schememod+eval name datum ...) + (schememod+eval #:eval eval-expr name datum ...)]]{ + +Combines @scheme[schememod] and @scheme[interaction-eval].} + + +@defform*[[(def+int defn-datum expr-datum ...) + (def+int #:eval eval-expr defn-datum expr-datum ...)]]{ + +Like @scheme[interaction], except the the @scheme[defn-datum] is +typeset as for @scheme[schemeblock] (i.e., no prompt) and a line of +space is inserted before the @scheme[expr-datum]s.} + + +@defform*[[(defs+int (defn-datum ...) expr-datum ...) + (defs+int #:eval eval-expr (defn-datum ...) expr-datum ...)]]{ + +Like @scheme[def+int], but for multiple leading definitions.} + + +@defform*[[(examples datum ...) + (examples #:eval eval-expr datum ...)]]{ + +Like @scheme[interaction], but with an ``Examples:'' label prefixed.} + + +@defform*[[(defexamples datum ...) + (defexamples #:eval eval-expr datum ...)]]{ + +Like @scheme[examples], but each definition using @scheme[define] or +@scheme[define-struct] among the @scheme[datum]s is typeset without a +prompt, and with line of space after it.} + + +@defproc[(make-base-eval) (any/c . -> . any)]{ + +Creates an evaluator using @scheme[(make-evaluator 'scheme/base)], +setting sandbox parameters to disable limits, set the outputs to +@scheme['string], and not add extra security guards.} + + +@defparam[scribble-eval-handler handler + ((any/c . -> . any) any/c boolean? . -> . any)]{ + +A parameter that serves as a hook for evaluation. The evaluator to use +is supplied as the first argument to the parameter's value, and the +second argument is the form to evaluate. The last argument is +@scheme[#t] if exceptions are being captured (to display exception +results), @scheme[#f] otherwise.} diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index 95976c79..db9e1af8 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -5,6 +5,9 @@ @require["utils.ss"] @require[(for-syntax scheme/base)] +@(define read-eval (make-base-eval)) +@interaction-eval[#:eval read-eval (require (for-syntax scheme/base))] + @title[#:tag "reader"]{@"@"-Reader} The Scribble @"@"-reader is designed to be a convenient facility for @@ -649,6 +652,7 @@ example, implicitly quoted keywords: @; FIXME: a bit of code duplication here @def+int[ + #:eval read-eval (define-syntax (foo stx) (let ([p (syntax-property stx 'scribble)]) (syntax-case stx () @@ -687,6 +691,7 @@ an example of this. @; FIXME: a bit of code duplication here @def+int[ + #:eval read-eval (define-syntax (verb stx) (syntax-case stx () [(_ cmd item ...)