346 lines
12 KiB
Scheme
346 lines
12 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'sandbox)
|
|
|
|
(require mzlib/sandbox)
|
|
|
|
(let ([ev void])
|
|
(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--
|
|
(set! ev (make-evaluator 'mzscheme '()
|
|
(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 'mzscheme '() '(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 'mzscheme '())))
|
|
--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 'mzscheme '() '(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 'mzscheme '() '(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 'mzscheme '() '(define id (lambda (x) x))))
|
|
--eval--
|
|
(id 123) => 123
|
|
--top--
|
|
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x))
|
|
'(define fooo 999)))
|
|
--eval--
|
|
(id fooo) => 999
|
|
|
|
;; test source locations too
|
|
--top--
|
|
(make-evaluator 'mzscheme '() 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 'mzscheme '()))
|
|
--eval--
|
|
(define x (+ 1 2 3)) => (void)
|
|
x => 6
|
|
(define x (+ x 10)) => (void)
|
|
x => 16
|
|
--top--
|
|
(set! ev (make-evaluator 'mzscheme '() '(define x (+ 1 2 3))))
|
|
--eval--
|
|
(define x (+ x 10)) =err> "cannot re-define a constant"
|
|
|
|
;; whole program argument
|
|
--top--
|
|
(set! ev (make-evaluator '(module foo mzscheme (define x 1))))
|
|
--eval--
|
|
x => 1
|
|
--top--
|
|
(set! ev (make-evaluator '(module foo mzscheme (provide x) (define x 1))))
|
|
--eval--
|
|
x => 1
|
|
(define x 2) =err> "cannot re-define a constant"
|
|
|
|
;; limited FS access, allowed for requires
|
|
--top--
|
|
(when (directory-exists? "/tmp") ; non-collects place to play with
|
|
(let* ([mzlib (path->string (collection-path "mzlib"))]
|
|
[list-lib (path->string (build-path mzlib "list.ss"))]
|
|
[test-lib (path->string (path->complete-path ; <- for windows
|
|
"/tmp/sandbox-test.ss"))])
|
|
(t --top--
|
|
(set! ev (make-evaluator 'mzscheme '()))
|
|
--eval--
|
|
;; reading from collects is allowed
|
|
(list (directory-list ,mzlib))
|
|
(file-exists? ,list-lib) => #t
|
|
(input-port? (open-input-file ,list-lib)) => #t
|
|
;; writing is forbidden
|
|
(open-output-file ,list-lib) =err> "file access denied"
|
|
;; reading from other places is forbidden
|
|
(directory-list "/tmp") =err> "file access denied"
|
|
;; no network too
|
|
(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 mzscheme
|
|
(define x 123) (provide x))))
|
|
#:exists 'replace)
|
|
(set! ev (make-evaluator 'mzscheme `(,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--
|
|
;; should work also for module evaluators
|
|
;; --> NO! Shouldn't make user code require whatever it wants
|
|
;; (set! ev (make-evaluator `(module foo mzscheme
|
|
;; (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 (let ([rx (if (eq? 'windows (system-type))
|
|
;; on windows this will have a drive letter
|
|
#rx#"^[a-zA-Z]:[/\\]tmp(?:[/\\]|$)"
|
|
#rx#"^/tmp(?:/|$)")])
|
|
(parameterize ([sandbox-path-permissions
|
|
;; allow all `/tmp' paths for windows
|
|
`((read ,rx)
|
|
,@(sandbox-path-permissions))])
|
|
(make-evaluator 'mzscheme '()))))
|
|
--eval--
|
|
(length (with-input-from-file ,test-lib read)) => 5
|
|
(list? (directory-list "/tmp"))
|
|
(open-output-file "/tmp/blah") =err> "file access denied"
|
|
(delete-directory "/tmp/blah") =err> "file access denied"
|
|
)))
|
|
|
|
;; languages and requires
|
|
--top--
|
|
(set! ev (make-evaluator 'r5rs '() "(define x (eq? 'x 'X))"))
|
|
--eval--
|
|
x => #t
|
|
--top--
|
|
(set! ev (make-evaluator 'mzscheme '() "(define l null)"))
|
|
--eval--
|
|
(cond [null? l 0]) => 0
|
|
(last-pair l) =err> "reference to an identifier"
|
|
--top--
|
|
(set! ev (make-evaluator '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 'mzscheme '((lib "list.ss")) '()))
|
|
--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 'mzscheme '()
|
|
(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 'mzscheme '() '(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
|
|
|
|
))
|
|
|
|
(report-errs)
|