diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 907d876bb0..6219973a6d 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -21,7 +21,9 @@ sandbox-network-guard sandbox-make-inspector sandbox-make-logger + sandbox-memory-limit sandbox-eval-limits + evaluator-alive? kill-evaluator break-evaluator set-eval-limits @@ -52,6 +54,7 @@ (define sandbox-output (make-parameter #f)) (define sandbox-error-output (make-parameter (lambda () (dup-output-port (current-error-port))))) +(define sandbox-memory-limit (make-parameter 20)) ; 30mb total (define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb (define sandbox-propagate-breaks (make-parameter #t)) (define sandbox-coverage-enabled (make-parameter #f)) @@ -465,6 +468,7 @@ (let ([evmsg (make-evaluator-message msg '())]) (lambda (evaluator) (evaluator evmsg))))])) +(define-evaluator-messenger evaluator-alive? 'alive?) (define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger break-evaluator 'break) (define-evaluator-messenger (set-eval-limits secs mb) 'limits) @@ -477,6 +481,7 @@ (define (make-evaluator* init-hook allow program-maker) (define orig-cust (current-custodian)) (define user-cust (make-custodian orig-cust)) + (define user-cust-box (make-custodian-box user-cust #t)) (define coverage? (sandbox-coverage-enabled)) (define uncovered #f) (define input-ch (make-channel)) @@ -569,6 +574,9 @@ (if (evaluator-message? expr) (let ([msg (evaluator-message-msg expr)]) (case msg + [(alive?) (and (custodian-box-value user-cust-box) + user-thread + (not (thread-dead? user-thread)))] [(kill) (user-kill)] [(break) (user-break)] [(limits) (set! limits (evaluator-message-args expr))] @@ -599,6 +607,10 @@ (if bytes? buf (bytes->string/utf-8 buf #\?))))) out)] [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) + ;; set global memory limit + (when (sandbox-memory-limit) + (custodian-limit-memory + user-cust (* (sandbox-memory-limit) 1024 1024) user-cust)) (parameterize* ; the order in these matters (;; create a sandbox context first [current-custodian user-cust] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 0e69330221..c76e0cb376 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -176,8 +176,11 @@ environment: @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].} + @item{The evaluator is contained in a memory-restricted environment, + and each evaluation is wrapped in a @scheme[call-with-limits] + (when memory accounting is available); see also + @scheme[sandbox-memory-limit], @scheme[sandbox-eval-limits] and + @scheme[set-eval-limits].} ] Note that these limits apply to the creation of the sandbox environment too --- so, for example, if the memory that is required to @@ -466,6 +469,15 @@ default @scheme[sandbox-security-guard]. The default forbids all network connection.} +@defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{ + +A parameter that determines the total memory limit on the sandbox. +When this limit is exceeded, the sandbox is terminated. This value is +used when the sandbox is created and the limit cannot be changed +afterwards. See @scheme[sandbox-eval-limits] for per-evaluation +limits and a description of how the two limits work together.} + + @defparam[sandbox-eval-limits limits (or/c (list/c (or/c exact-nonnegative-integer? #f) (or/c exact-nonnegative-integer? #f)) @@ -473,12 +485,13 @@ network connection.} 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 (useful in case more limit kinds are -available in future versions). The default is @scheme[(list 30 20)]. +of the input program. Its value should be a list of two numbers; +where 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 per-evaluation limits (useful in +case more limit kinds are available in future versions). The default +is @scheme[(list 30 20)]. Note that these limits apply to the creation of the sandbox environment too --- even @scheme[(make-evaluator 'scheme/base)] can @@ -488,7 +501,45 @@ you need to catch errors that happen when the sandbox is created. 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. Change the limits of a running evaluator -using @scheme[set-eval-limits].} +using @scheme[set-eval-limits]. + +@margin-note{A custodian's limit is checked only after a garbage + collection, except that it may also be checked during + certain large allocations that are individually larger + than the custodian's limit.} + +The memory limit that is specified by this parameter applies to each +individual evaluation, but not to the whole sandbox --- that limit is +specified via @scheme[sandbox-memory-limit]. When the global limit is +exceeded, the sandbox is terminated, but when the per-evaluation limit +is exceeded the @exnraise[exn:fail:resource]. For example, say that +you evaluate an expression like +@schemeblock[ + (for ([i (in-range 1000)]) + (set! a (cons (make-bytes 1000000) a)) + (collect-garbage)) +] +then, assuming sufficiently small limits, +@itemize[ + + @item{if a global limit is set but no per-evaluation limit, the + sandbox will eventually be terminated and no further + evaluations possible;} + + @item{if there is a per-evaluation limit, but no global limit, the + evaluation will abort with an error and it can be used again + --- specifically, @scheme[a] will still hold a number of + blocks, and you can evaluate the same expression again which + will add more blocks to it;} + + @item{if both limits are set, with the global one larger than the + per-evaluation limit, then the evaluation will abort and you + will be able to repeat it, but doing so several times will + eventually terminate the sandbox (this will be indicated by + the error message, and by the @scheme[evaluator-alive?] + predicate).} + +]} @defparam[sandbox-make-inspector make (-> inspector?)]{ @@ -510,6 +561,12 @@ evaluator, and the default parameter value is @scheme[current-logger].} The following functions are used to interact with a sandboxed evaluator in addition to using it to evaluate code. + +@defproc[(evaluator-alive? [evaluator (any/c . -> . any)]) boolean?]{ + +Determines whether the evaluator is still alive.} + + @defproc[(kill-evaluator [evaluator (any/c . -> . any)]) void?]{ Releases the resources that are held by @scheme[evaluator] by shutting diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 8bca31d979..10c1068f70 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -64,326 +64,328 @@ (t -;! ;; basic stuff, limits -;! --top-- -;! (set! ev (make-evaluator 'scheme/base -;! (make-prog "(define x 1)" -;! "(define (id x) x)" -;! "(define (plus1 x) x)" -;! "(define (loop) (loop))" -;! "(define (memory x) (make-vector x))"))) -;! (set-eval-limits ev 1 3) -;! --eval-- -;! x => 1 -;! (id 1) => 1 -;! (id (plus1 x)) => 1 -;! (define id2 id) -;! (id2 (id x)) => 1 -;! blah =err> "before its definition" -;! ;; using a string for an input -;! "1" => 1 -;! "(+ 1 2) x (define y 9) y (set! y 99) y" => 99 -;! "bad\"string" =err> "expected a closing" -;! "bad(string" =err> "expected a .\\)." -;! "bad)string" =err> "unexpected .\\)." -;! "(set! y 999) (string" =err> "expected a .\\)." -;! y => 99 -;! "(set! y 999) (if)" =err> "if: bad syntax" -;! y => 999 -;! ;; test limits -;! (loop) =err> "out of time" -;! --top-- -;! (when (custodian-memory-accounting-available?) -;! (t --eval-- (memory 1000000) =err> "out of memory")) -;! ;; test parameter settings (tricky to get this right since -;! ;; with-limits runs stuff in a different thread) -;! (set-eval-limits ev #f #f) -;! --eval-- -;! (define p (make-parameter 0)) -;! (p) => 0 -;! (p 1) -;! (p) => 1 -;! (thread-wait (thread (lambda () (p 100)))) -;! (p) => 1 -;! --top-- -;! (set-eval-limits ev 1 3) -;! --eval-- -;! (p) => 1 -;! (p 2) -;! (p) => 2 -;! (thread-wait (thread (lambda () (p 100)))) -;! (p) => 2 -;! --top-- -;! (set-eval-limits ev #f #f) -;! --eval-- -;! (p) => 2 -;! ;; breaking -;! --top-- -;! (thread (lambda () (sleep 1) (break-evaluator ev))) -;! --eval-- -;! (sleep 2) =err> "user break" -;! ;; termination -;! --eval-- -;! (printf "x = ~s\n" x) => (void) -;! ,eof =err> "terminated" -;! x =err> "terminated" -;! ,eof =err> "terminated" -;! -;! ;; i/o -;! --top-- -;! (set! ev (parameterize ([sandbox-input "3\n"] -;! [sandbox-output 'string] -;! [sandbox-error-output current-output-port]) -;! (make-evaluator 'scheme/base '(define x 123)))) -;! --eval-- (printf "x = ~s\n" x) => (void) -;! --top-- (get-output ev) => "x = 123\n" -;! --eval-- (printf "x = ~s\n" x) => (void) -;! --top-- (get-output ev) => "x = 123\n" -;! --eval-- (printf "x*2 = ~s\n" (+ x x)) => (void) -;! (printf "x*10 = ~s\n" (* 10 x)) => (void) -;! --top-- (get-output ev) => "x*2 = 246\nx*10 = 1230\n" -;! --eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void) -;! --top-- (get-output ev) => "x*(read) = 369\n" -;! --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) -;! --top-- (get-output ev) => "a\nb\n" -;! (get-error-output ev) => #f -;! --top-- -;! (set! ev (parameterize ([sandbox-output 'string] -;! [sandbox-error-output 'string]) -;! (make-evaluator 'scheme/base))) -;! --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) -;! --top-- (get-output ev) => "a\n" -;! (get-error-output ev) => "b\n" -;! --top-- -;! (set! ev (parameterize ([sandbox-input 'pipe] -;! [sandbox-output 'bytes] -;! [sandbox-error-output current-output-port] -;! [sandbox-eval-limits '(0.25 10)]) -;! (make-evaluator 'scheme/base '(define x 123)))) -;! --eval-- (begin (printf "x = ~s\n" x) -;! (fprintf (current-error-port) "err\n")) -;! --top-- (get-output ev) => #"x = 123\nerr\n" -;! (put-input ev "blah\n") -;! (put-input ev "blah\n") -;! --eval-- (read-line) => "blah" -;! (printf "line = ~s\n" (read-line)) -;! --top-- (get-output ev) => #"line = \"blah\"\n" -;! --eval-- (read-line) =err> "out of time" -;! --top-- (put-input ev "blah\n") -;! (put-input ev eof) -;! --eval-- (read-line) => "blah" -;! (read-line) => eof -;! (read-line) => eof -;! ;; test kill-evaluator here -;! --top-- -;! (kill-evaluator ev) => (void) -;! --eval-- -;! x =err> "terminated" -;! y =err> "terminated" -;! ,eof =err> "terminated" -;! --top-- -;! (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) -;! ;; o1 -> i1 -ev-> o2 -> i2 -;! (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2]) -;! (make-evaluator 'scheme/base '(define x 123)))) -;! (t --eval-- (printf "x = ~s\n" x) => (void) -;! --top-- (read-line i2) => "x = 123" -;! --eval-- (printf "x = ~s\n" x) => (void) -;! --top-- (read-line i2) => "x = 123" -;! --eval-- (printf "x*2 = ~s\n" (+ x x)) => (void) -;! (printf "x*10 = ~s\n" (* 10 x)) => (void) -;! --top-- (read-line i2) => "x*2 = 246" -;! (read-line i2) => "x*10 = 1230" -;! (fprintf o1 "3\n") -;! --eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void) -;! --top-- (read-line i2) => "x*(read) = 369" -;! )) -;! -;! ;; sexprs as a program -;! --top-- -;! (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)))) -;! --eval-- -;! (id 123) => 123 -;! --top-- -;! (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)) -;! '(define fooo 999))) -;! --eval-- -;! (id fooo) => 999 -;! -;! ;; test source locations too -;! --top-- -;! (make-evaluator 'scheme/base 0 1 2 '(define foo)) -;! =err> "program:4:0: define" -;! -;! ;; empty program for clean repls -;! --top-- -;! (set! ev (make-evaluator '(begin))) -;! --eval-- -;! (define x (+ 1 2 3)) => (void) -;! x => 6 -;! (define x (+ x 10)) => (void) -;! x => 16 -;! --top-- -;! (set! ev (make-evaluator 'scheme/base)) -;! --eval-- -;! (define x (+ 1 2 3)) => (void) -;! x => 6 -;! (define x (+ x 10)) => (void) -;! x => 16 -;! --top-- -;! (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3)))) -;! --eval-- -;! (define x (+ x 10)) =err> "cannot re-define a constant" -;! -;! ;; whole program argument -;! --top-- -;! (set! ev (make-module-evaluator '(module foo scheme/base (define x 1)))) -;! --eval-- -;! x => 1 -;! --top-- -;! (set! ev (make-module-evaluator -;! '(module foo scheme/base (provide x) (define x 1)))) -;! --eval-- -;! x => 1 -;! (define x 2) =err> "cannot re-define a constant" -;! -;! ;; limited FS access, allowed for requires -;! --top-- -;! (let* ([tmp (find-system-path 'temp-dir)] -;! [schemelib (path->string (collection-path "scheme"))] -;! [list-lib (path->string (build-path schemelib "list.ss"))] -;! [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) -;! (t --top-- -;! (set! ev (make-evaluator 'scheme/base)) -;! --eval-- -;! ;; reading from collects is allowed -;! (list (directory-list ,schemelib)) -;! (file-exists? ,list-lib) => #t -;! (input-port? (open-input-file ,list-lib)) => #t -;! ;; writing is forbidden -;! (open-output-file ,list-lib) =err> "`write' access denied" -;! ;; reading from other places is forbidden -;! (directory-list ,tmp) =err> "`read' access denied" -;! ;; no network too -;! (require scheme/tcp) -;! (tcp-listen 12345) =err> "network access denied" -;! --top-- -;! ;; reading from a specified require is fine -;! (with-output-to-file test-lib -;! (lambda () -;! (printf "~s\n" '(module sandbox-test scheme/base -;! (define x 123) (provide x)))) -;! #:exists 'replace) -;! (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) -;! --eval-- -;! x => 123 -;! (length (with-input-from-file ,test-lib read)) => 5 -;! ;; the directory is still not kosher -;! (directory-list ,tmp) =err> "`read' access denied" -;! --top-- -;! ;; should work also for module evaluators -;! ;; --> NO! Shouldn't make user code require whatever it wants -;! ;; (set! ev (make-evaluator `(module foo scheme/base -;! ;; (require (file ,test-lib))))) -;! ;; --eval-- -;! ;; x => 123 -;! ;; (length (with-input-from-file ,test-lib read)) => 5 -;! ;; ;; the directory is still not kosher -;! ;; (directory-list tmp) =err> "file access denied" -;! --top-- -;! ;; explicitly allow access to tmp -;! (set! ev (parameterize ([sandbox-path-permissions -;! `((read ,tmp) -;! ,@(sandbox-path-permissions))]) -;! (make-evaluator 'scheme/base))) -;! --eval-- -;! (length (with-input-from-file ,test-lib read)) => 5 -;! (list? (directory-list ,tmp)) -;! (open-output-file ,(build-path tmp "blah")) =err> "access denied" -;! (delete-directory ,(build-path tmp "blah")) =err> "access denied") -;! (delete-file test-lib)) -;! -;! ;; languages and requires -;! --top-- -;! (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))")) -;! --eval-- -;! x => #t -;! --top-- -;! (set! ev (make-evaluator 'scheme/base "(define l null)")) -;! --eval-- -;! (cond [null? l 0]) => 0 -;! (last-pair l) =err> "reference to an identifier" -;! --top-- -;! (set! ev (make-evaluator '(special beginner) -;! (make-prog "(define l null)" "(define x 3.5)"))) -;! --eval-- -;! (cond [null? l 0]) =err> "expected an open parenthesis" -;! --top-- -;! (eq? (ev "6") (ev "(sub1 (* 2 3.5))")) -;! (eq? (ev "6") (ev "(sub1 (* 2 x))")) -;! --top-- -;! (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list))) -;! --eval-- -;! (last-pair '(1 2 3)) => '(3) -;! (last-pair null) =err> "expected argument of type" -;! -;! ;; coverage -;! --top-- -;! (set! ev (parameterize ([sandbox-coverage-enabled #t]) -;! (make-evaluator 'scheme/base -;! (make-prog "(define (foo x) (+ x 1))" -;! "(define (bar x) (+ x 2))" -;! "(equal? (foo 3) 4)")))) -;! (pair? (get-uncovered-expressions ev)) -;! (pair? (get-uncovered-expressions ev #t)) -;! --eval-- -;! (foo 3) => 4 -;! (bar 10) => 12 -;! --top-- -;! (null? (get-uncovered-expressions ev #f)) -;! (pair? (get-uncovered-expressions ev)) ; no-tests coverage still the same -;! -;! ;; misc parameters -;! --top-- -;! (set! ev (parameterize ([sandbox-init-hook -;! (let ([old (sandbox-init-hook)]) -;! (lambda () -;! (old) -;! (compile-enforce-module-constants #f) -;! (compile-allow-set!-undefined #t)))]) -;! (make-evaluator 'scheme/base '(define x 123)))) -;! --eval-- -;! (set! x 456) ; would be an error without the `enforce' parameter -;! x => 456 -;! (set! y 789) ; would be an error without the `set!' parameter -;! y => 789 -;! -;! ;; test that output is also collected under the limit -;! --top-- -;! (set! ev (parameterize ([sandbox-output 'bytes] -;! [sandbox-error-output current-output-port] -;! [sandbox-eval-limits '(0.25 1/2)]) -;! (make-evaluator 'scheme/base))) -;! ;; GCing is needed to allow these to happen -;! --eval-- (display (make-bytes 400000 65)) -;! --top-- (bytes-length (get-output ev)) => 400000 -;! --eval-- (display (make-bytes 400000 65)) -;! --top-- (bytes-length (get-output ev)) => 400000 -;! --eval-- (display (make-bytes 400000 65)) -;! --top-- (bytes-length (get-output ev)) => 400000 -;! --eval-- (display (make-bytes 400000 65)) -;! --top-- (bytes-length (get-output ev)) => 400000 -;! --eval-- (display (make-bytes 400000 65)) -;! --top-- (bytes-length (get-output ev)) => 400000 -;! ;; EB: for some reason, the first thing doesn't throw an error, and I think -;! ;; that the second should break much sooner than 100 iterations -;! ;; --eval-- (let ([400k (make-bytes 400000 65)]) -;! ;; (for ([i (in-range 2)]) (display 400k))) -;! ;; --top-- (bytes-length (get-output ev)) -;! ;; =err> "out of memory" -;! ;; --eval-- (let ([400k (make-bytes 400000 65)]) -;! ;; (for ([i (in-range 100)]) (display 400k))) -;! ;; =err> "out of memory" + ;; basic stuff, limits + --top-- + (set! ev (make-evaluator 'scheme/base + (make-prog "(define x 1)" + "(define (id x) x)" + "(define (plus1 x) x)" + "(define (loop) (loop))" + "(define (memory x) (make-vector x))"))) + (set-eval-limits ev 1 3) + --eval-- + x => 1 + (id 1) => 1 + (id (plus1 x)) => 1 + (define id2 id) + (id2 (id x)) => 1 + blah =err> "before its definition" + ;; using a string for an input + "1" => 1 + "(+ 1 2) x (define y 9) y (set! y 99) y" => 99 + "bad\"string" =err> "expected a closing" + "bad(string" =err> "expected a .\\)." + "bad)string" =err> "unexpected .\\)." + "(set! y 999) (string" =err> "expected a .\\)." + y => 99 + "(set! y 999) (if)" =err> "if: bad syntax" + y => 999 + ;; test limits + (loop) =err> "out of time" + --top-- + (when (custodian-memory-accounting-available?) + (t --eval-- (memory 1000000) =err> "out of memory")) + ;; test parameter settings (tricky to get this right since + ;; with-limits runs stuff in a different thread) + (set-eval-limits ev #f #f) + --eval-- + (define p (make-parameter 0)) + (p) => 0 + (p 1) + (p) => 1 + (thread-wait (thread (lambda () (p 100)))) + (p) => 1 + --top-- + (set-eval-limits ev 1 3) + --eval-- + (p) => 1 + (p 2) + (p) => 2 + (thread-wait (thread (lambda () (p 100)))) + (p) => 2 + --top-- + (set-eval-limits ev #f #f) + --eval-- + (p) => 2 + ;; breaking + --top-- + (thread (lambda () (sleep 1) (break-evaluator ev))) + --eval-- + (sleep 2) =err> "user break" + ;; termination + --eval-- + (printf "x = ~s\n" x) => (void) + ,eof =err> "terminated" + x =err> "terminated" + ,eof =err> "terminated" + + ;; i/o + --top-- + (set! ev (parameterize ([sandbox-input "3\n"] + [sandbox-output 'string] + [sandbox-error-output current-output-port]) + (make-evaluator 'scheme/base '(define x 123)))) + --eval-- (printf "x = ~s\n" x) => (void) + --top-- (get-output ev) => "x = 123\n" + --eval-- (printf "x = ~s\n" x) => (void) + --top-- (get-output ev) => "x = 123\n" + --eval-- (printf "x*2 = ~s\n" (+ x x)) => (void) + (printf "x*10 = ~s\n" (* 10 x)) => (void) + --top-- (get-output ev) => "x*2 = 246\nx*10 = 1230\n" + --eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void) + --top-- (get-output ev) => "x*(read) = 369\n" + --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) + --top-- (get-output ev) => "a\nb\n" + (get-error-output ev) => #f + --top-- + (set! ev (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string]) + (make-evaluator 'scheme/base))) + --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) + --top-- (get-output ev) => "a\n" + (get-error-output ev) => "b\n" + --top-- + (set! ev (parameterize ([sandbox-input 'pipe] + [sandbox-output 'bytes] + [sandbox-error-output current-output-port] + [sandbox-eval-limits '(0.25 10)]) + (make-evaluator 'scheme/base '(define x 123)))) + --eval-- (begin (printf "x = ~s\n" x) + (fprintf (current-error-port) "err\n")) + --top-- (get-output ev) => #"x = 123\nerr\n" + (put-input ev "blah\n") + (put-input ev "blah\n") + --eval-- (read-line) => "blah" + (printf "line = ~s\n" (read-line)) + --top-- (get-output ev) => #"line = \"blah\"\n" + --eval-- (read-line) =err> "out of time" + --top-- (put-input ev "blah\n") + (put-input ev eof) + --eval-- (read-line) => "blah" + (read-line) => eof + (read-line) => eof + ;; test kill-evaluator here + --top-- + (kill-evaluator ev) => (void) + --eval-- + x =err> "terminated" + y =err> "terminated" + ,eof =err> "terminated" + --top-- + (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) + ;; o1 -> i1 -ev-> o2 -> i2 + (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2]) + (make-evaluator 'scheme/base '(define x 123)))) + (t --eval-- (printf "x = ~s\n" x) => (void) + --top-- (read-line i2) => "x = 123" + --eval-- (printf "x = ~s\n" x) => (void) + --top-- (read-line i2) => "x = 123" + --eval-- (printf "x*2 = ~s\n" (+ x x)) => (void) + (printf "x*10 = ~s\n" (* 10 x)) => (void) + --top-- (read-line i2) => "x*2 = 246" + (read-line i2) => "x*10 = 1230" + (fprintf o1 "3\n") + --eval-- (printf "x*(read) = ~s\n" (* x (read))) => (void) + --top-- (read-line i2) => "x*(read) = 369" + )) + + ;; sexprs as a program + --top-- + (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)))) + --eval-- + (id 123) => 123 + --top-- + (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)) + '(define fooo 999))) + --eval-- + (id fooo) => 999 + + ;; test source locations too + --top-- + (make-evaluator 'scheme/base 0 1 2 '(define foo)) + =err> "program:4:0: define" + + ;; empty program for clean repls + --top-- + (set! ev (make-evaluator '(begin))) + --eval-- + (define x (+ 1 2 3)) => (void) + x => 6 + (define x (+ x 10)) => (void) + x => 16 + --top-- + (set! ev (make-evaluator 'scheme/base)) + --eval-- + (define x (+ 1 2 3)) => (void) + x => 6 + (define x (+ x 10)) => (void) + x => 16 + --top-- + (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3)))) + --eval-- + (define x (+ x 10)) =err> "cannot re-define a constant" + + ;; whole program argument + --top-- + (set! ev (make-module-evaluator '(module foo scheme/base (define x 1)))) + --eval-- + x => 1 + --top-- + (set! ev (make-module-evaluator + '(module foo scheme/base (provide x) (define x 1)))) + --eval-- + x => 1 + (define x 2) =err> "cannot re-define a constant" + + ;; limited FS access, allowed for requires + --top-- + (let* ([tmp (find-system-path 'temp-dir)] + [schemelib (path->string (collection-path "scheme"))] + [list-lib (path->string (build-path schemelib "list.ss"))] + [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) + (t --top-- + (set! ev (make-evaluator 'scheme/base)) + --eval-- + ;; reading from collects is allowed + (list (directory-list ,schemelib)) + (file-exists? ,list-lib) => #t + (input-port? (open-input-file ,list-lib)) => #t + ;; writing is forbidden + (open-output-file ,list-lib) =err> "`write' access denied" + ;; reading from other places is forbidden + (directory-list ,tmp) =err> "`read' access denied" + ;; no network too + (require scheme/tcp) + (tcp-listen 12345) =err> "network access denied" + --top-- + ;; reading from a specified require is fine + (with-output-to-file test-lib + (lambda () + (printf "~s\n" '(module sandbox-test scheme/base + (define x 123) (provide x)))) + #:exists 'replace) + (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) + --eval-- + x => 123 + (length (with-input-from-file ,test-lib read)) => 5 + ;; the directory is still not kosher + (directory-list ,tmp) =err> "`read' access denied" + --top-- + ;; should work also for module evaluators + ;; --> NO! Shouldn't make user code require whatever it wants + ;; (set! ev (make-evaluator `(module foo scheme/base + ;; (require (file ,test-lib))))) + ;; --eval-- + ;; x => 123 + ;; (length (with-input-from-file ,test-lib read)) => 5 + ;; ;; the directory is still not kosher + ;; (directory-list tmp) =err> "file access denied" + --top-- + ;; explicitly allow access to tmp + (set! ev (parameterize ([sandbox-path-permissions + `((read ,tmp) + ,@(sandbox-path-permissions))]) + (make-evaluator 'scheme/base))) + --eval-- + (length (with-input-from-file ,test-lib read)) => 5 + (list? (directory-list ,tmp)) + (open-output-file ,(build-path tmp "blah")) =err> "access denied" + (delete-directory ,(build-path tmp "blah")) =err> "access denied") + (delete-file test-lib)) + + ;; languages and requires + --top-- + (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))")) + --eval-- + x => #t + --top-- + (set! ev (make-evaluator 'scheme/base "(define l null)")) + --eval-- + (cond [null? l 0]) => 0 + (last-pair l) =err> "reference to an identifier" + --top-- + (set! ev (make-evaluator '(special beginner) + (make-prog "(define l null)" "(define x 3.5)"))) + --eval-- + (cond [null? l 0]) =err> "expected an open parenthesis" + --top-- + (eq? (ev "6") (ev "(sub1 (* 2 3.5))")) + (eq? (ev "6") (ev "(sub1 (* 2 x))")) + --top-- + (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list))) + --eval-- + (last-pair '(1 2 3)) => '(3) + (last-pair null) =err> "expected argument of type" + + ;; coverage + --top-- + (set! ev (parameterize ([sandbox-coverage-enabled #t]) + (make-evaluator 'scheme/base + (make-prog "(define (foo x) (+ x 1))" + "(define (bar x) (+ x 2))" + "(equal? (foo 3) 4)")))) + (pair? (get-uncovered-expressions ev)) + (pair? (get-uncovered-expressions ev #t)) + --eval-- + (foo 3) => 4 + (bar 10) => 12 + --top-- + (null? (get-uncovered-expressions ev #f)) + (pair? (get-uncovered-expressions ev)) ; no-tests coverage still the same + + ;; misc parameters + --top-- + (set! ev (parameterize ([sandbox-init-hook + (let ([old (sandbox-init-hook)]) + (lambda () + (old) + (compile-enforce-module-constants #f) + (compile-allow-set!-undefined #t)))]) + (make-evaluator 'scheme/base '(define x 123)))) + --eval-- + (set! x 456) ; would be an error without the `enforce' parameter + x => 456 + (set! y 789) ; would be an error without the `set!' parameter + y => 789 + + ;; test that output is also collected under the limit + --top-- + (set! ev (parameterize ([sandbox-output 'bytes] + [sandbox-error-output current-output-port] + [sandbox-memory-limit 5] + [sandbox-eval-limits '(0.25 1/2)]) + (make-evaluator 'scheme/base))) + ;; GCing is needed to allow these to happen + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 + --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000 ;; test that killing the custodian works fine ;; first try it without limits (limits imply a nested thread/custodian) @@ -428,13 +430,14 @@ ;; when an expression is out of memory, the sandbox should stay alive --top-- - (set! ev (parameterize ([sandbox-eval-limits '(2 5)]) + (set! ev (parameterize ([sandbox-eval-limits '(2 5)] + [sandbox-memory-limit 100]) (make-evaluator 'scheme/base))) --eval-- (define a '()) (define b 1) (for ([i (in-range 20)]) - (set! a (cons (make-bytes 1000000) a)) + (set! a (cons (make-bytes 500000) a)) (collect-garbage)) =err> "out of memory" b => 1