499 lines
18 KiB
Scheme
499 lines
18 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'sandbox)
|
|
|
|
(require scheme/sandbox)
|
|
|
|
;; test call-in-nested-thread*
|
|
(let ()
|
|
(define (kill) (kill-thread (current-thread)))
|
|
(define (shut) (custodian-shutdown-all (current-custodian)))
|
|
(define-syntax-rule (nested body ...)
|
|
(call-in-nested-thread* (lambda () body ...)))
|
|
(define-syntax-rule (nested* body ...)
|
|
(call-in-nested-thread* (lambda () body ...)
|
|
(lambda () 'kill)
|
|
(lambda () 'shut)))
|
|
(test 1 values (nested 1))
|
|
;; propagates parameters
|
|
(let ([p (make-parameter #f)])
|
|
(nested (p 1))
|
|
(test 1 p)
|
|
(with-handlers ([void void]) (nested (p 2) (error "foo") (p 3)))
|
|
(test 2 p))
|
|
;; propagates kill-thread
|
|
(test (void) thread-wait
|
|
(thread (lambda ()
|
|
(nested (kill))
|
|
;; never reach here
|
|
(semaphore-wait (make-semaphore 0)))))
|
|
;; propagates custodian-shutdown-all
|
|
(test (void) values
|
|
(parameterize ([current-custodian (make-custodian)]) (nested (shut))))
|
|
;; test handlers parameters
|
|
(test 'kill (lambda () (nested* (kill))))
|
|
(test 'shut (lambda () (nested* (shut)))))
|
|
|
|
(let ([ev void])
|
|
(define (make-evaluator! . args)
|
|
(set! ev (apply make-evaluator args)))
|
|
(define (make-base-evaluator! . args)
|
|
(set! ev (apply make-evaluator 'scheme/base args)))
|
|
(define (make-base-evaluator/reqs! reqs . args)
|
|
(set! ev (apply make-evaluator 'scheme/base #:requires reqs args)))
|
|
(define (make-module-evaluator! . args)
|
|
(set! ev (apply make-module-evaluator args)))
|
|
(define (run thunk)
|
|
(with-handlers ([void (lambda (e) (list 'exn: e))])
|
|
(call-with-values thunk (lambda vs (cons 'vals: vs)))))
|
|
(define (run* thunk)
|
|
(with-handlers ([void (lambda (e) (list 'exn: e))])
|
|
(call-with-values thunk
|
|
(case-lambda [(x) (and x #t)] [vs (cons 'vals: vs)]))))
|
|
(define (e-match? re run thunk)
|
|
(let ([x (run thunk)])
|
|
(if (and (list? x) (= 2 (length x)) (eq? 'exn: (car x)) (exn? (cadr x)))
|
|
(let ([m (exn-message (cadr x))])
|
|
(or (regexp-match? re m) (list 'bad-exception-message: m)))
|
|
x)))
|
|
(define-syntax thunk (syntax-rules () [(thunk b ...) (lambda () b ...)]))
|
|
(define-syntax t
|
|
(syntax-rules (--eval-- --top-- => <= =err> <err=)
|
|
[(t -?-) (void)]
|
|
[(t -?- --eval-- more ...) (t --eval-- more ...)]
|
|
[(t -?- --top-- more ...) (t --top-- more ...)]
|
|
[(t --eval-- E) (test #t run* (thunk (ev `E)))]
|
|
[(t --top-- E) (test #t run* (thunk E))]
|
|
[(t --eval-- E => R) (test `(vals: ,R) run (thunk (ev `E)))]
|
|
[(t --top-- E => R) (test `(vals: ,R) run (thunk E))]
|
|
[(t --eval-- E =err> R) (test #t e-match? R run (thunk (ev `E)))]
|
|
[(t --top-- E =err> R) (test #t e-match? R run (thunk E))]
|
|
[(t -?- E => R more ...) (begin (t -?- E => R) (t -?- more ...))]
|
|
[(t -?- E =err> R more ...) (begin (t -?- E =err> R) (t -?- more ...))]
|
|
[(t -?- R <= E more ...) (t -?- E => R more ...)]
|
|
[(t -?- R <err= E more ...) (t E =err> R more ...)]
|
|
;; last so it doesn't match the above
|
|
[(t -?- E more ...) (begin (t -?- E) (t -?- more ...))]))
|
|
(define (make-prog . lines)
|
|
(apply string-append (map (lambda (l) (string-append l "\n")) lines)))
|
|
|
|
(t
|
|
|
|
;; basic stuff, limits
|
|
--top--
|
|
(make-base-evaluator!
|
|
(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 0.5 5)
|
|
--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 3000000) =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"
|
|
(printf "x = ~s\n" x) => (void)
|
|
;; termination
|
|
--eval--
|
|
,eof =err> "terminated .eof.$"
|
|
123 =err> "terminated .eof.$"
|
|
,eof =err> "terminated .eof.$"
|
|
|
|
;; other termination messages
|
|
--top-- (make-base-evaluator!) (kill-evaluator ev)
|
|
--eval-- 123 =err> "terminated .evaluator-killed.$"
|
|
|
|
;; nested calls are forbidden
|
|
--top-- (make-base-evaluator!)
|
|
--eval-- (,ev 1) =err> "nested evaluator call"
|
|
|
|
;; eval-limits apply to the sandbox creation too
|
|
--top--
|
|
(parameterize ([sandbox-eval-limits '(0.25 5)])
|
|
(make-base-evaluator! '(sleep 2)))
|
|
=err> "out of time"
|
|
(when (custodian-memory-accounting-available?)
|
|
(t --top--
|
|
(parameterize ([sandbox-eval-limits '(2 2)])
|
|
(make-base-evaluator! '(define a (for/list ([i (in-range 10)])
|
|
(collect-garbage)
|
|
(make-bytes 500000)))))
|
|
=err> "out of memor(?:y)"))
|
|
|
|
;; i/o
|
|
--top--
|
|
(parameterize ([sandbox-input "3\n"]
|
|
[sandbox-output 'string]
|
|
[sandbox-error-output current-output-port])
|
|
(make-base-evaluator! '(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--
|
|
(parameterize ([sandbox-output 'string] [sandbox-error-output 'string])
|
|
(make-base-evaluator!))
|
|
--eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
|
|
--top-- (get-output ev) => "a\n"
|
|
(get-error-output ev) => "b\n"
|
|
--top--
|
|
(parameterize ([sandbox-input 'pipe]
|
|
[sandbox-output 'bytes]
|
|
[sandbox-error-output current-output-port]
|
|
[sandbox-eval-limits '(0.25 10)])
|
|
(make-base-evaluator! '(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 .evaluator-killed.$"
|
|
y =err> "terminated .evaluator-killed.$"
|
|
,eof =err> "terminated .evaluator-killed.$"
|
|
--top--
|
|
(let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
|
|
;; o1 -> i1 -ev-> o2 -> i2
|
|
(parameterize ([sandbox-input i1] [sandbox-output o2])
|
|
(make-base-evaluator! '(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--
|
|
(make-base-evaluator! '(define id (lambda (x) x)))
|
|
--eval--
|
|
(id 123) => 123
|
|
--top--
|
|
(make-base-evaluator! '(define id (lambda (x) x)) '(define fooo 999))
|
|
--eval--
|
|
(id fooo) => 999
|
|
|
|
;; test source locations too
|
|
--top--
|
|
(make-base-evaluator! 0 1 2 '(define foo))
|
|
=err> "program:4:0: define"
|
|
|
|
;; empty program for clean repls
|
|
--top--
|
|
(make-evaluator! '(begin))
|
|
--eval--
|
|
(define x (+ 1 2 3)) => (void)
|
|
x => 6
|
|
(define x (+ x 10)) => (void)
|
|
x => 16
|
|
--top--
|
|
(make-base-evaluator!)
|
|
--eval--
|
|
(define x (+ 1 2 3)) => (void)
|
|
x => 6
|
|
(define x (+ x 10)) => (void)
|
|
x => 16
|
|
--top--
|
|
(make-base-evaluator! '(define x (+ 1 2 3)))
|
|
--eval--
|
|
(define x (+ x 10)) =err> "cannot re-define a constant"
|
|
|
|
;; whole program argument
|
|
--top--
|
|
(make-module-evaluator! '(module foo scheme/base (define x 1)))
|
|
--eval--
|
|
x => 1
|
|
--top--
|
|
(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 (make-temporary-file "sandboxtest~a" 'directory)]
|
|
[strpath (lambda xs (path->string (apply build-path xs)))]
|
|
[schemelib (strpath (collection-path "scheme"))]
|
|
[list-lib (strpath schemelib "list.ss")]
|
|
[list-zo (strpath schemelib "compiled" "list_ss.zo")]
|
|
[test-lib (strpath tmp "sandbox-test.ss")]
|
|
[test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")]
|
|
[test2-lib (strpath tmp "sandbox-test2.ss")]
|
|
[test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")])
|
|
(t --top--
|
|
(make-base-evaluator!)
|
|
--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)))))
|
|
(make-base-evaluator/reqs! `(,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
|
|
;; (make-module-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, and write access to a single file
|
|
(make-directory (build-path tmp "compiled"))
|
|
(parameterize ([sandbox-path-permissions
|
|
`((read ,tmp) (write ,test-zo)
|
|
,@(sandbox-path-permissions))])
|
|
(make-base-evaluator!))
|
|
--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"
|
|
(list? (directory-list ,schemelib))
|
|
;; we can read/write/delete list-zo, but we can't load bytecode from
|
|
;; it due to the code inspector
|
|
(copy-file ,list-zo ,test-zo) => (void)
|
|
(copy-file ,test-zo ,list-zo) =err> "access denied"
|
|
(load/use-compiled ,test-lib) => (void)
|
|
(require 'list) =err> "access from an uncertified context"
|
|
(delete-file ,test-zo) => (void)
|
|
(delete-file ,test-lib) =err> "`delete' access denied"
|
|
--top--
|
|
;; a more explicit test of bytcode loading, allowing rw access to the
|
|
;; complete tmp directory, but read-bytecode only for test2-lib
|
|
(parameterize ([sandbox-path-permissions
|
|
`((write ,tmp) (read-bytecode ,test2-lib)
|
|
,@(sandbox-path-permissions))])
|
|
(make-base-evaluator!))
|
|
--eval--
|
|
(define (cp from to)
|
|
(when (file-exists? to) (delete-file to))
|
|
(copy-file from to))
|
|
(cp ,list-lib ,test-lib) (cp ,list-zo ,test-zo)
|
|
(cp ,list-lib ,test2-lib) (cp ,list-zo ,test2-zo)
|
|
;; bytecode from test-lib is bad, even when we can read/write to it
|
|
(load/use-compiled ,test-zo)
|
|
(require 'list) =err> "access from an uncertified context"
|
|
;; bytecode from test2-lib is explicitly allowed
|
|
(load/use-compiled ,test2-lib)
|
|
(require 'list) => (void))
|
|
((dynamic-require 'scheme/file 'delete-directory/files) tmp))
|
|
|
|
;; languages and requires
|
|
--top--
|
|
(make-evaluator! '(special r5rs) "(define x (eq? 'x 'X))")
|
|
--eval--
|
|
x => #t
|
|
--top--
|
|
(make-base-evaluator! "(define l null)")
|
|
--eval--
|
|
(cond [null? l 0]) => 0
|
|
(last-pair l) =err> "reference to an identifier"
|
|
--top--
|
|
(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--
|
|
(make-base-evaluator/reqs! '(scheme/list))
|
|
--eval--
|
|
(last-pair '(1 2 3)) => '(3)
|
|
(last-pair null) =err> "expected argument of type"
|
|
|
|
;; coverage
|
|
--top--
|
|
(parameterize ([sandbox-coverage-enabled #t])
|
|
(make-base-evaluator!
|
|
(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--
|
|
(parameterize ([sandbox-init-hook
|
|
(let ([old (sandbox-init-hook)])
|
|
(lambda ()
|
|
(old)
|
|
(compile-enforce-module-constants #f)
|
|
(compile-allow-set!-undefined #t)))])
|
|
(make-base-evaluator! '(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--
|
|
(parameterize ([sandbox-output 'bytes]
|
|
[sandbox-error-output current-output-port]
|
|
[sandbox-memory-limit 2]
|
|
[sandbox-eval-limits '(0.25 1)])
|
|
(make-base-evaluator!))
|
|
;; GCing is needed to allow these to happen (note: the memory limit is very
|
|
;; tight here, this test usually fails if the sandbox library is not
|
|
;; compiled)
|
|
(let ([t (lambda ()
|
|
(t --eval-- (display (make-bytes 400000 65)) (collect-garbage)
|
|
--top-- (bytes-length (get-output ev)) => 400000))])
|
|
;; can go arbitrarily high here
|
|
(for ([i (in-range 20)]) (t)))
|
|
|
|
;; test that killing the thread, shutting the custodian, or calling `exit'
|
|
;; works fine first try it without limits (limits imply a nested
|
|
;; thread/custodian)
|
|
--top--
|
|
(let ()
|
|
(define (3x2-terminations)
|
|
(t --top-- (make-base-evaluator!) --eval--
|
|
(kill-thread (current-thread)) =err> "terminated .thread-killed.$"
|
|
--top-- (make-base-evaluator!) --eval--
|
|
(custodian-shutdown-all (current-custodian))
|
|
=err> "terminated .custodian-shutdown.$"
|
|
--top-- (make-base-evaluator!) --eval--
|
|
(exit) =err> "terminated .exited.$"
|
|
;; now test that it's fine when called directly
|
|
--top--
|
|
(make-base-evaluator!)
|
|
(call-in-sandbox-context ev
|
|
(lambda () (kill-thread (current-thread))))
|
|
=err> "terminated .thread-killed.$"
|
|
(make-base-evaluator!)
|
|
(call-in-sandbox-context ev
|
|
(lambda () (custodian-shutdown-all (current-custodian))))
|
|
=err> "terminated .custodian-shutdown.$"
|
|
(make-base-evaluator!)
|
|
(call-in-sandbox-context ev exit) =err> "terminated .exited.$"))
|
|
(define (test-terminations)
|
|
;; try without, then with per-expression limits
|
|
(parameterize ([sandbox-eval-limits #f]) (3x2-terminations))
|
|
(3x2-terminations))
|
|
(test-terminations))
|
|
|
|
;; when an expression is out of memory, the sandbox should stay alive
|
|
--top--
|
|
(when (custodian-memory-accounting-available?)
|
|
(t --top--
|
|
(parameterize ([sandbox-eval-limits '(2 5)]
|
|
[sandbox-memory-limit 100])
|
|
(make-base-evaluator!))
|
|
--eval--
|
|
(define a '())
|
|
(define b 1)
|
|
(length
|
|
(for/fold ([v null]) ([i (in-range 20)])
|
|
;; increases size of sandbox: it's reachable from it (outside of
|
|
;; this evaluation) because `a' is defined there
|
|
(set! a (cons (make-bytes 500000) a))
|
|
(collect-garbage)
|
|
;; increases size of the current evaluation
|
|
(cons (make-bytes 500000) v)))
|
|
=err> "out of memo(?:ry)"
|
|
b => 1))
|
|
|
|
))
|
|
|
|
(report-errs)
|