235 lines
10 KiB
Scheme
235 lines
10 KiB
Scheme
(module sandbox mzscheme
|
|
(require (lib "string.ss") (lib "list.ss"))
|
|
|
|
(provide mred?
|
|
coverage-enabled
|
|
namespace-specs
|
|
sandbox-reader
|
|
sandbox-security-guard
|
|
get-uncovered-expressions
|
|
make-evaluator)
|
|
|
|
(define mred?
|
|
(with-handlers ([void (lambda (_) #f)])
|
|
(dynamic-require '#%mred-kernel #f)
|
|
#t))
|
|
(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding
|
|
(syntax-rules ()
|
|
[(mz/mr mzval mrsym)
|
|
(if mred? (dynamic-require '(lib "mred.ss" "mred") 'mrsym) mzval)]))
|
|
|
|
;; Configuration ------------------------------------------------------------
|
|
|
|
(define coverage-enabled (make-parameter #f))
|
|
|
|
(define namespace-specs
|
|
(make-parameter
|
|
(let ([mods '((lib "posn.ss" "lang"))]
|
|
[mred-mods '((lib "cache-image-snip.ss" "mrlib"))])
|
|
`(,(mz/mr make-namespace make-namespace-with-mred)
|
|
,@mods ,@(if mred? mred-mods '())))))
|
|
|
|
(define (default-sandbox-reader)
|
|
(parameterize ([read-case-sensitive #t] [read-decimal-as-inexact #f])
|
|
(let loop ([l '()])
|
|
(let ([expr (read-syntax 'program)])
|
|
(if (eof-object? expr)
|
|
(reverse! l)
|
|
(loop (cons expr l)))))))
|
|
|
|
(define sandbox-reader (make-parameter default-sandbox-reader))
|
|
|
|
(define ok-path-re
|
|
(byte-regexp
|
|
(bytes-append
|
|
#"^(?:"
|
|
(apply bytes-append
|
|
(cdr (apply append
|
|
(map (lambda (p)
|
|
(list #"|" (regexp-quote (path->bytes p))))
|
|
(current-library-collection-paths)))))
|
|
#")(?:/|$)")))
|
|
|
|
(define sandbox-security-guard
|
|
(make-parameter
|
|
(make-security-guard
|
|
(current-security-guard)
|
|
(lambda (what path modes)
|
|
(when (or (memq 'write modes)
|
|
(memq 'execute modes)
|
|
(memq 'delete modes)
|
|
(and path
|
|
(not (regexp-match? ok-path-re (path->bytes path)))))
|
|
(error what "file access denied (~a)" path)))
|
|
(lambda (what host port mode) (error what "network access denied")))))
|
|
|
|
(define null-input (open-input-string ""))
|
|
(define (safe-eval expr)
|
|
(parameterize ([current-security-guard (sandbox-security-guard)]
|
|
[current-input-port null-input]
|
|
;; breaks: [current-code-inspector (make-inspector)]
|
|
)
|
|
(eval expr)))
|
|
|
|
;; Execution ----------------------------------------------------------------
|
|
|
|
(define (make-evaluation-namespace)
|
|
(let* ([specs (namespace-specs)]
|
|
[new-ns ((car specs))]
|
|
[orig-ns (current-namespace)]
|
|
[mods (cdr specs)]
|
|
[resolve (current-module-name-resolver)])
|
|
(for-each (lambda (mod) (dynamic-require mod #f)) mods)
|
|
(let ([modsyms (map (lambda (mod) (resolve mod #f #f)) mods)])
|
|
(parameterize ([current-namespace new-ns])
|
|
(for-each (lambda (ms) (namespace-attach-module orig-ns ms))
|
|
modsyms)))
|
|
new-ns))
|
|
|
|
(define (read-code inp)
|
|
(parameterize ([current-input-port
|
|
(cond [(input-port? inp) inp]
|
|
[(string? inp) (open-input-string inp)]
|
|
[(bytes? inp) (open-input-bytes inp)]
|
|
[(path? inp) (open-input-file inp)]
|
|
[else (error 'read-code "bad input: ~e" inp)])])
|
|
(port-count-lines! (current-input-port))
|
|
((sandbox-reader))))
|
|
|
|
(define (evaluate-program language teachpacks input-program uncovered!)
|
|
(let* ([body (read-code input-program)]
|
|
[body (append (if (and (pair? teachpacks)
|
|
(eq? 'begin (car teachpacks)))
|
|
(cdr teachpacks)
|
|
(map (lambda (tp)
|
|
`(,#'require ,(if (pair? tp) tp `(file ,tp))))
|
|
teachpacks))
|
|
body)]
|
|
[body (cond [(and (symbol? language)
|
|
(memq language '(beginner
|
|
beginner-abbr
|
|
intermediate
|
|
intermediate-lambda
|
|
advanced)))
|
|
`(module m
|
|
(lib ,(case language
|
|
[(beginner) "htdp-beginner.ss"]
|
|
[(beginner-abbr) "htdp-beginner-abbr.ss"]
|
|
[(intermediate) "htdp-intermediate.ss"]
|
|
[(intermediate-lambda)
|
|
"htdp-intermediate-lambda.ss"]
|
|
[(advanced) "htdp-advanced.ss"])
|
|
"lang")
|
|
,@body)]
|
|
[(or (and (pair? language) (eq? 'lib (car language)))
|
|
(symbol? language))
|
|
`(module m ,language ,@body)]
|
|
[(and (pair? language)
|
|
(eq? 'begin (car language)))
|
|
`(begin ,language ,@body)]
|
|
[else (error 'make-evaluator
|
|
"Bad language specification: ~e"
|
|
language)])]
|
|
[ns (current-namespace)])
|
|
(when uncovered!
|
|
(safe-eval '(require (lib "coverage.ss" "handin-server" "private"))))
|
|
(safe-eval body)
|
|
(when (and (pair? body) (eq? 'module (car body))
|
|
(pair? (cdr body)) (symbol? (cadr body)))
|
|
(let ([mod (cadr body)])
|
|
(safe-eval `(require ,mod))
|
|
(current-namespace (module->namespace mod))))
|
|
(when uncovered!
|
|
(uncovered! (filter (lambda (x) (eq? 'program (syntax-source x)))
|
|
(parameterize ([current-namespace ns])
|
|
(safe-eval '(get-uncovered-expressions))))))))
|
|
|
|
(define current-eventspace (mz/mr (make-parameter #f) current-eventspace))
|
|
(define make-eventspace (mz/mr void make-eventspace))
|
|
(define run-in-bg (mz/mr thread queue-callback))
|
|
|
|
(define (get-uncovered-expressions eval) (eval get-uncovered-expressions))
|
|
|
|
(define (make-evaluator language teachpacks input-program)
|
|
(let ([coverage-enabled (coverage-enabled)]
|
|
[uncovered-expressions #f]
|
|
[ns (make-evaluation-namespace)]
|
|
[input-ch (make-channel)]
|
|
[result-ch (make-channel)])
|
|
(parameterize ([current-namespace ns]
|
|
[current-inspector (make-inspector)])
|
|
;; Note the above definition of `current-eventspace': in MzScheme, it
|
|
;; is a parameter that is not used at all. Also note that creating an
|
|
;; eventspace starts a thread that will eventually run the callback
|
|
;; code (which evaluates the program in `run-in-bg') -- so this
|
|
;; parameterization must be nested in the above, or it will not use the
|
|
;; new namespace.
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(run-in-bg
|
|
(lambda ()
|
|
;; First read program and evaluate it as a module:
|
|
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
|
|
(evaluate-program
|
|
language teachpacks input-program
|
|
(and coverage-enabled
|
|
(lambda (exprs) (set! uncovered-expressions exprs))))
|
|
(channel-put result-ch 'ok))
|
|
;; Now wait for interaction expressions:
|
|
(let loop ()
|
|
(let ([expr (channel-get input-ch)])
|
|
(unless (eof-object? expr)
|
|
(with-handlers ([void (lambda (exn)
|
|
(channel-put result-ch
|
|
(cons 'exn exn)))])
|
|
(channel-put result-ch
|
|
(cons 'vals (call-with-values
|
|
(lambda () (safe-eval expr))
|
|
list))))
|
|
(loop))))
|
|
(let loop ()
|
|
(channel-put result-ch '(exn . no-more-to-evaluate))
|
|
(loop))))
|
|
(let ([r (channel-get result-ch)])
|
|
(if (eq? r 'ok)
|
|
;; Initial program executed ok, so return an evaluator:
|
|
(lambda (expr)
|
|
(if (eq? expr get-uncovered-expressions)
|
|
uncovered-expressions
|
|
(begin (channel-put input-ch expr)
|
|
(let ([r (channel-get result-ch)])
|
|
(if (eq? (car r) 'exn)
|
|
(raise (cdr r))
|
|
(apply values (cdr r)))))))
|
|
;; Program didn't execute:
|
|
(raise r)))))))
|
|
|
|
;; Resources ----------------------------------------------------------------
|
|
|
|
(define (call-with-limits sec mb thunk)
|
|
(let ([cust (make-custodian)]
|
|
[ch (make-channel)])
|
|
(when mb (custodian-limit-memory cust (* mb 1024 1024) cust))
|
|
(let* ([work (parameterize ([current-custodian cust])
|
|
(thread (lambda ()
|
|
(channel-put ch
|
|
(with-handlers ([void (lambda (e)
|
|
(list raise e))])
|
|
(call-with-values thunk
|
|
(lambda vs (cons values vs))))))))]
|
|
[watch (thread (lambda ()
|
|
(channel-put ch
|
|
(if (sync/timeout sec work) 'memory 'time))))]
|
|
[r (channel-get ch)])
|
|
(custodian-shutdown-all cust)
|
|
(kill-thread watch)
|
|
(if (list? r)
|
|
(apply (car r) (cdr r))
|
|
(error 'with-limit "out of ~a" r)))))
|
|
|
|
(define-syntax with-limits
|
|
(syntax-rules ()
|
|
[(with-limits sec mb body ...)
|
|
(call-with-limits sec mb (lambda () body ...))]))
|
|
|
|
)
|