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

switch to scheme/base for the sandbox interface and for use in tests

Browse Source 
svn: r12656
This commit is contained in:
Eli Barzilay 2008-12-01 03:37:02 +00:00
parent 7ea8ab6592
commit 30adf7980a
1 changed files with 34 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/tests/mzscheme/sandbox.ss
View File

@ -3,7 +3,7 @@
(Section 'sandbox) (Section 'sandbox)
(require mzlib/sandbox) (require scheme/sandbox)
(let ([ev void]) (let ([ev void])
(define (run thunk) (define (run thunk)
@ -44,7 +44,7 @@
;; basic stuff, limits ;; basic stuff, limits
--top-- --top--
(set! ev (make-evaluator 'mzscheme '() (set! ev (make-evaluator 'scheme/base
(make-prog "(define x 1)" (make-prog "(define x 1)"
"(define (id x) x)" "(define (id x) x)"
"(define (plus1 x) x)" "(define (plus1 x) x)"
@ -112,7 +112,7 @@
(set! ev (parameterize ([sandbox-input "3\n"] (set! ev (parameterize ([sandbox-input "3\n"]
[sandbox-output 'string] [sandbox-output 'string]
[sandbox-error-output current-output-port]) [sandbox-error-output current-output-port])
(make-evaluator 'mzscheme '() '(define x 123)))) (make-evaluator 'scheme/base '(define x 123))))
--eval-- (printf "x = ~s\n" x) => (void) --eval-- (printf "x = ~s\n" x) => (void)
--top-- (get-output ev) => "x = 123\n" --top-- (get-output ev) => "x = 123\n"
--eval-- (printf "x = ~s\n" x) => (void) --eval-- (printf "x = ~s\n" x) => (void)
@ -128,7 +128,7 @@
--top-- --top--
(set! ev (parameterize ([sandbox-output 'string] (set! ev (parameterize ([sandbox-output 'string]
[sandbox-error-output 'string]) [sandbox-error-output 'string])
(make-evaluator 'mzscheme '()))) (make-evaluator 'scheme/base)))
--eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
--top-- (get-output ev) => "a\n" --top-- (get-output ev) => "a\n"
(get-error-output ev) => "b\n" (get-error-output ev) => "b\n"
@ -137,7 +137,7 @@
[sandbox-output 'bytes] [sandbox-output 'bytes]
[sandbox-error-output current-output-port] [sandbox-error-output current-output-port]
[sandbox-eval-limits '(0.25 10)]) [sandbox-eval-limits '(0.25 10)])
(make-evaluator 'mzscheme '() '(define x 123)))) (make-evaluator 'scheme/base '(define x 123))))
--eval-- (begin (printf "x = ~s\n" x) --eval-- (begin (printf "x = ~s\n" x)
(fprintf (current-error-port) "err\n")) (fprintf (current-error-port) "err\n"))
--top-- (get-output ev) => #"x = 123\nerr\n" --top-- (get-output ev) => #"x = 123\nerr\n"
@ -163,7 +163,7 @@
(let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
;; o1 -> i1 -ev-> o2 -> i2 ;; o1 -> i1 -ev-> o2 -> i2
(set! ev (parameterize ([sandbox-input i1] [sandbox-output o2]) (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2])
(make-evaluator 'mzscheme '() '(define x 123)))) (make-evaluator 'scheme/base '(define x 123))))
(t --eval-- (printf "x = ~s\n" x) => (void) (t --eval-- (printf "x = ~s\n" x) => (void)
--top-- (read-line i2) => "x = 123" --top-- (read-line i2) => "x = 123"
--eval-- (printf "x = ~s\n" x) => (void) --eval-- (printf "x = ~s\n" x) => (void)
@ -179,62 +179,63 @@
;; sexprs as a program ;; sexprs as a program
--top-- --top--
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x)))) (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))))
--eval-- --eval--
(id 123) => 123 (id 123) => 123
--top-- --top--
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x)) (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))
'(define fooo 999))) '(define fooo 999)))
--eval-- --eval--
(id fooo) => 999 (id fooo) => 999
;; test source locations too ;; test source locations too
--top-- --top--
(make-evaluator 'mzscheme '() 0 1 2 '(define foo)) (make-evaluator 'scheme/base 0 1 2 '(define foo))
=err> "program:4:0: define" =err> "program:4:0: define"
;; empty program for clean repls ;; empty program for clean repls
--top-- --top--
(set! ev (make-evaluator '(begin) '())) (set! ev (make-evaluator '(begin)))
--eval-- --eval--
(define x (+ 1 2 3)) => (void) (define x (+ 1 2 3)) => (void)
x => 6 x => 6
(define x (+ x 10)) => (void) (define x (+ x 10)) => (void)
x => 16 x => 16
--top-- --top--
(set! ev (make-evaluator 'mzscheme '())) (set! ev (make-evaluator 'scheme/base))
--eval-- --eval--
(define x (+ 1 2 3)) => (void) (define x (+ 1 2 3)) => (void)
x => 6 x => 6
(define x (+ x 10)) => (void) (define x (+ x 10)) => (void)
x => 16 x => 16
--top-- --top--
(set! ev (make-evaluator 'mzscheme '() '(define x (+ 1 2 3)))) (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3))))
--eval-- --eval--
(define x (+ x 10)) =err> "cannot re-define a constant" (define x (+ x 10)) =err> "cannot re-define a constant"
;; whole program argument ;; whole program argument
--top-- --top--
(set! ev (make-evaluator '(module foo mzscheme (define x 1)))) (set! ev (make-module-evaluator '(module foo scheme/base (define x 1))))
--eval-- --eval--
x => 1 x => 1
--top-- --top--
(set! ev (make-evaluator '(module foo mzscheme (provide x) (define x 1)))) (set! ev (make-module-evaluator
'(module foo scheme/base (provide x) (define x 1))))
--eval-- --eval--
x => 1 x => 1
(define x 2) =err> "cannot re-define a constant" (define x 2) =err> "cannot re-define a constant"
;; limited FS access, allowed for requires ;; limited FS access, allowed for requires
--top-- --top--
(let* ([tmp (find-system-path 'temp-dir)] (let* ([tmp (find-system-path 'temp-dir)]
[mzlib (path->string (collection-path "mzlib"))] [schemelib (path->string (collection-path "scheme"))]
[list-lib (path->string (build-path mzlib "list.ss"))] [list-lib (path->string (build-path schemelib "list.ss"))]
[test-lib (path->string (build-path tmp "sandbox-test.ss"))]) [test-lib (path->string (build-path tmp "sandbox-test.ss"))])
(t --top-- (t --top--
(set! ev (make-evaluator 'mzscheme '())) (set! ev (make-evaluator 'scheme/base))
--eval-- --eval--
;; reading from collects is allowed ;; reading from collects is allowed
(list (directory-list ,mzlib)) (list (directory-list ,schemelib))
(file-exists? ,list-lib) => #t (file-exists? ,list-lib) => #t
(input-port? (open-input-file ,list-lib)) => #t (input-port? (open-input-file ,list-lib)) => #t
;; writing is forbidden ;; writing is forbidden
@ -242,15 +243,16 @@
;; reading from other places is forbidden ;; reading from other places is forbidden
(directory-list ,tmp) =err> "`read' access denied" (directory-list ,tmp) =err> "`read' access denied"
;; no network too ;; no network too
(require scheme/tcp)
(tcp-listen 12345) =err> "network access denied" (tcp-listen 12345) =err> "network access denied"
--top-- --top--
;; reading from a specified require is fine ;; reading from a specified require is fine
(with-output-to-file test-lib (with-output-to-file test-lib
(lambda () (lambda ()
(printf "~s\n" '(module sandbox-test mzscheme (printf "~s\n" '(module sandbox-test scheme/base
(define x 123) (provide x)))) (define x 123) (provide x))))
#:exists 'replace) #:exists 'replace)
(set! ev (make-evaluator 'mzscheme `(,test-lib))) (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
--eval-- --eval--
x => 123 x => 123
(length (with-input-from-file ,test-lib read)) => 5 (length (with-input-from-file ,test-lib read)) => 5
@ -259,7 +261,7 @@
--top-- --top--
;; should work also for module evaluators ;; should work also for module evaluators
;; --> NO! Shouldn't make user code require whatever it wants ;; --> NO! Shouldn't make user code require whatever it wants
;; (set! ev (make-evaluator `(module foo mzscheme ;; (set! ev (make-evaluator `(module foo scheme/base
;; (require (file ,test-lib))))) ;; (require (file ,test-lib)))))
;; --eval-- ;; --eval--
;; x => 123 ;; x => 123
@ -271,7 +273,7 @@
(set! ev (parameterize ([sandbox-path-permissions (set! ev (parameterize ([sandbox-path-permissions
`((read ,tmp) `((read ,tmp)
,@(sandbox-path-permissions))]) ,@(sandbox-path-permissions))])
(make-evaluator 'mzscheme '()))) (make-evaluator 'scheme/base)))
--eval-- --eval--
(length (with-input-from-file ,test-lib read)) => 5 (length (with-input-from-file ,test-lib read)) => 5
(list? (directory-list ,tmp)) (list? (directory-list ,tmp))
@ -281,24 +283,24 @@
;; languages and requires ;; languages and requires
--top-- --top--
(set! ev (make-evaluator 'r5rs '() "(define x (eq? 'x 'X))")) (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))"))
--eval-- --eval--
x => #t x => #t
--top-- --top--
(set! ev (make-evaluator 'mzscheme '() "(define l null)")) (set! ev (make-evaluator 'scheme/base "(define l null)"))
--eval-- --eval--
(cond [null? l 0]) => 0 (cond [null? l 0]) => 0
(last-pair l) =err> "reference to an identifier" (last-pair l) =err> "reference to an identifier"
--top-- --top--
(set! ev (make-evaluator 'beginner '() (make-prog "(define l null)" (set! ev (make-evaluator '(special beginner)
"(define x 3.5)"))) (make-prog "(define l null)" "(define x 3.5)")))
--eval-- --eval--
(cond [null? l 0]) =err> "expected an open parenthesis" (cond [null? l 0]) =err> "expected an open parenthesis"
--top-- --top--
(eq? (ev "6") (ev "(sub1 (* 2 3.5))")) (eq? (ev "6") (ev "(sub1 (* 2 3.5))"))
(eq? (ev "6") (ev "(sub1 (* 2 x))")) (eq? (ev "6") (ev "(sub1 (* 2 x))"))
--top-- --top--
(set! ev (make-evaluator 'mzscheme '(mzlib/list) '())) (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list)))
--eval-- --eval--
(last-pair '(1 2 3)) => '(3) (last-pair '(1 2 3)) => '(3)
(last-pair null) =err> "expected argument of type" (last-pair null) =err> "expected argument of type"
@ -306,7 +308,7 @@
;; coverage ;; coverage
--top-- --top--
(set! ev (parameterize ([sandbox-coverage-enabled #t]) (set! ev (parameterize ([sandbox-coverage-enabled #t])
(make-evaluator 'mzscheme '() (make-evaluator 'scheme/base
(make-prog "(define (foo x) (+ x 1))" (make-prog "(define (foo x) (+ x 1))"
"(define (bar x) (+ x 2))" "(define (bar x) (+ x 2))"
"(equal? (foo 3) 4)")))) "(equal? (foo 3) 4)"))))
@ -327,7 +329,7 @@
(old) (old)
(compile-enforce-module-constants #f) (compile-enforce-module-constants #f)
(compile-allow-set!-undefined #t)))]) (compile-allow-set!-undefined #t)))])
(make-evaluator 'mzscheme '() '(define x 123)))) (make-evaluator 'scheme/base '(define x 123))))
--eval-- --eval--
(set! x 456) ; would be an error without the `enforce' parameter (set! x 456) ; would be an error without the `enforce' parameter
x => 456 x => 456