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

* Factored out and generalized sandbox code for standalone testing

Browse Source 
* Renamed "extra-utils.ss" to "checker.ss"

svn: r5356
This commit is contained in:
Eli Barzilay 2007-01-16 02:21:29 +00:00
parent 0a36385258
commit c98b4a15b2
5 changed files with 382 additions and 231 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
collects/handin-server/extra-utils.ss → collects/handin-server/checker.ss
View File

187
collects/handin-server/doc.txt
View File

@ -33,7 +33,7 @@ server and each user's password.
Quick Start for a Test Drive:
============================================
=============================
1. Create a new directory.
@ -83,10 +83,8 @@ Quick Start for a Test Drive:
-------------------------------------------------------------------
Client Customization
============================================
To customize the client:
Client Customization:
=====================
1. Rename (or make a copy of) the "handin-client" collection
directory. The new name should describe your class uniquely.
@ -139,8 +137,8 @@ To customize the client:
--all-users flag.
Server Setup
============================================
Server Setup:
=============
You must prepare a special directory to host the handin server. To
run the server, you should either be in this directory, or you should
@ -556,26 +554,102 @@ to start with a specific assignment (named ASSIGNMENT). The default
PORT is 7980.
Checker Utilities
============================================
Checker Utilities:
==================
The _utils.ss_ module provides utilities helpful in implementing
`checker' functions:
The checker utilities are provided to make writing checker functions.
They are provided in a few layers, each layer provides new
functionality in addition to the lower one. These modules are (in
order):
> (get-conf key)
Returns a value from the configuration file (useful for reading
things like field names etc)
* sandbox.ss -- basic sandbox evaluation utilities, can be used
independently from the handin-server.
> (unpack-submission bytes)
Returns two text% objects corresponding to the submitted definitions
and interactions windows.
* utils.ss -- additional utilities for dealing with handin
submissions, as well as a few helpers for testing code.
> (make-evaluator language teachpack-paths program-port)
Returns a function of one required argument for evaluating
expressions in the designated language, and loading teachpacks that
are specified in `teachpack-paths'. The `program-port' is an input
port that produces the content of the definitions window; use
`(open-input-string "")' for an empty definitions window.
* checker.ss -- this layer automates the task of creating a checker
function (in "<active-assignment>/checker.ss" modules) to cope with
common submission situations.
The following sections describe each of these modules.
_sandbox.ss_
------------
The main function that is implemented in this module is
`make-evaluator'. Most of the functionality that is provided is used
by this function.
> mred?
A boolean that is bound to `#t' if we're currently running in MrEd,
`#f' if in plain MzScheme. The idea is that you can use this module
both from MzScheme or, if needed, from MrEd. (Higher levels
("utils.ss" and "checker.ss"), need to be used with MrEd.)
> coverage-enabled
A boolean parameter that controls whether coverage testing is
enabled in `make-evaluator'-created functions. If it set to true,
the "handin-server/private/coverage.ss" module will be used to
detect uncovered expressions. This information is collected after
the input port has been evaluated, so it is not affected by testing
code that is not part of the submission. To retrieve the collected
information, apply the evaluation function on the special
`get-uncovered-expressions' value below. The resulting value is a
list of uncovered expressions, with at most one per position+span
(which means that the contents may be unreliable, but the position
is). The default is `#f'.
> get-uncovered-expressions
A special value that, when passed to an evaluator created by
`make-evaluator', will return a list of uncovered syntax objects.
> namespace-specs
A parameter that holds a list of values that specify how to create a
namespace for evaluation in `make-evaluator'. The first item in the
list is a thunk that creates the namespace, and the rest are require
specs for modules that are to be attached to the created namespace.
The default is `make-namespace' and `(lib "posn.ss" "lang")' if
running in MzScheme, or `make-namespace-with-mred' and
`(lib "cache-image-snip.ss" "mrlib")' as well as the posn library.
(The module specs are needed for sharing module instantiations, for
example, without the above, posn values in testing code will be a
different type from posn values in tested code.)
> sandbox-reader
A parameter that holds a function that reads all expressions from
the current-input-port. It is used to read the submission source.
It must return a list of syntax objects, and it must use the symbol
`program' as the input source (that is, something like a loop that
consumes the input using `(read-syntax 'program)'). The default
reader is using a plain `read-syntax' -- it does so while setting
`read-case-sensitive' to `#t', and `read-decimal-as-inexact' to `#f'
(both are sensible choices for testing code).
> sandbox-security-guard
A parameter that holds a security guard that is used by all
evaluations that happen in a `make-evaluator' function. The default
value is a security guard that forbids writing, deleting, execution,
acessing any paths outside of the collection paths, or any kind of
network activity.
> (make-evaluator language teachpack-paths input-program)
This is the main entry point for the sandbox module.
This function Creates an evaluator function for evaluating
expressions in the designated `language', after loading teachpacks
that are specified in `teachpack-paths', and after evaluating the
code in the `input-program'.
The `input-program' holds the input program in one of the following
ways:
* an input port that produces the content of the definitions window;
* a string or a byte string that contains the definitions window
(you can use "" for an empty definitions window);
* a path that names a file holding the input program.
The contents of the input program is read using the
`sandbox-reader', with line-counting enabled.
The `language' can be:
* a symbol indicating a built-in language (currently, only
@ -593,14 +667,34 @@ The _utils.ss_ module provides utilities helpful in implementing
* a list that begins with a 'begin symbol is arbitrary code that is
prefixed into the submitted program.
The actual evaluation of expressions happens in a newly created
eventspace and namespace, and under the supervision of a strict
security guard that reading files only from PLT collections, and no
other operations.
The actual evaluation of expressions (both the program and later
evaluations) happens under the `sandbox-security-guard'
restrictions, and if MrEd is used -- in a newly created eventspace.
See also `with-limits' below for adding resource limits, and
`get-uncovered-expressions' above for enforcing test coverage.
Additional arguments to the evaluator function are special messages
that retrieve additional information. Currently, only
'uncovered-expressions is used (see below).
> (with-limits sec mb thunk)
This function executes the given thunk with memory and time
restrictions: if execution consumes more than `mb' megabytes or more
that `sec' seconds, then the computation is aborted and an error is
thrown. Otherwise the result of the thunk is returned (a value,
multiple values, or raise an exception). Each of the two limits can
be `#f' to disable it.
(Note: memory limit requires running in a 3m executable; the limit
is only checked after a GC happens.)
_utils.ss_
----------
> (get-conf key)
Returns a value from the configuration file (useful for reading
things like field names etc)
> (unpack-submission bytes)
Returns two text% objects corresponding to the submitted definitions
and interactions windows.
> (make-evaluator/submission language teachpack-paths bytes)
Like `make-evaluator', but the definitions content is supplied as a
@ -626,17 +720,6 @@ The _utils.ss_ module provides utilities helpful in implementing
> (evaluate-submission bytes eval)
Like `load' on a submission byte string.
> coverage-enabled
Parameter that controls whether coverage testing is enabled. If it
set to true, the handin-server/private/coverage collection will be
used to detect uncovered expressions. This information is collected
before additional checker-evaluations. To retrieve the collected
information, apply the evaluation function with a second argument of
'uncovered-expressions (the first argument will be ignored). The
resulting value is a list of uncovered expressions, with at most one
per position+span (so the contents is unreliable, but the position
is).
> (check-proc eval expect-v compare-proc proc-name arg ...)
Calls the function named `proc-name' using the evaluator `eval',
giving it the (unquoted) arguments `arg'... Let `result-v' be the
@ -717,15 +800,15 @@ The _utils.ss_ module provides utilities helpful in implementing
specified), the timer will be reset to the 'session-timeout value.)
Extra Checker Utilities
============================================
_checker.ss_
------------
The _extra-utils.ss_ module provides a higher-level of utilities,
helpful in implementing `checker' functions that are intended for a
more automated system. This module is a language module -- a typical
The "checker.ss" module provides a higher-level of utilities, helpful
in implementing `checker' functions that are intended for a more
automated system. This module is a language module -- a typical
checker that uses it looks like this:
(module checker (lib "extra-utils.ss" "handin-server")
(module checker (lib "checker.ss" "handin-server")
(check: :language 'intermediate
:users pairs-or-singles-with-warning
:coverage? #t
@ -998,11 +1081,13 @@ value from the submission code.
you can call it earlier (eg, before testing) to show clients a
coverage error first.
*** Multiple-file submissions
Multiple-File Submissions:
==========================
By default, the system is set up for submissions of single a single
file, straight fom DrScheme using the handin-client. There is some
support for multi-file submissions in "extra-utils.ss" and in the
support for multi-file submissions in "checker.ss" and in the
handin-client -- it is possible to submit multiple files, and have the
system generate a single file that is the concatenation of all
submission files (used only with text files). To set up multi-file
@ -1050,7 +1135,9 @@ submission utility -- the resulting executable can be used outside of
DrScheme (but PLT Scheme is still required, so it cannot be
uninstalled).
*** Auto-updater
Auto-Updater:
=============
The handin-client has code that can be used for automatic updating of
clients. This can be useful for courses where you distribute some

19
collects/handin-server/handin-server.ss
View File

@ -550,13 +550,13 @@
(custodian-limit-memory session-cust
(get-conf 'session-memory-limit)
session-cust)))
(let* ([watcher
(parameterize ([current-custodian orig-custodian])
(thread
(lambda ()
(let ([session-thread (channel-get session-channel)])
(let loop ([timed-out? #f])
(cond
(let ([watcher
(parameterize ([current-custodian orig-custodian])
(thread
(lambda ()
(let ([session-thread (channel-get session-channel)])
(let loop ([timed-out? #f])
(cond
[(sync/timeout 3 session-thread)
(let* ([status (unbox status-box)]
[status (if status
@ -574,9 +574,8 @@
[(let ([t timeout]) ; grab value to avoid races
(and t ((current-inexact-milliseconds) . > . t)))
;; Shutdown here to get the handin-terminated error
;; message, instead of relying on
;; (get-conf 'session-timeout)
;; at the run-server level
;; message, instead of relying on a timeout at the
;; run-server level
(custodian-shutdown-all session-cust)
(loop #t)]
[else

222
collects/handin-server/sandbox.ss Normal file
View File

@ -0,0 +1,222 @@
(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)])])
(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)))
(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 "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)]
;; bogus parameter and value if we're in mzscheme
[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 (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)))))
)

185
collects/handin-server/utils.ss
View File

@ -1,20 +1,21 @@
(module utils mzscheme
(require (lib "class.ss")
(require (lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "posn.ss" "lang")
"private/run-status.ss"
"private/config.ss"
(prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss")
(lib "list.ss")
(lib "string.ss")
(only "handin-server.ss" timeout-control))
(only "handin-server.ss" timeout-control)
"private/run-status.ss"
"private/config.ss"
"sandbox.ss")
(provide get-conf
(provide (all-from "sandbox.ss")
get-conf
unpack-submission
make-evaluator
make-evaluator/submission
evaluate-all
evaluate-submission
@ -26,8 +27,6 @@
message
current-value-printer
coverage-enabled
check-proc
check-defined
look-for-tests
@ -48,170 +47,15 @@
(read-editor-global-footer stream)
(values definitions-text interactions-text)))
;; Protection ---------------------------------------
(define ok-path-re
(regexp
(string-append
"^(?:"
(apply string-append
(cdr (apply append
(map (lambda (p)
(list "|" (regexp-quote (path->string p))))
(current-library-collection-paths)))))
")(?:/|$)")))
(define tight-security
(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->string 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 . more)
(parameterize ([current-security-guard tight-security]
[current-input-port null-input]
;; breaks: [current-code-inspector (make-inspector)]
)
(apply eval expr more)))
;; Execution ----------------------------------------
(define coverage-enabled (make-parameter #f))
(define modules-to-attach
(list '(lib "posn.ss" "lang")
'(lib "cache-image-snip.ss" "mrlib")))
(define (make-evaluation-namespace)
(let ([new-ns (make-namespace-with-mred)]
[orig-ns (current-namespace)])
(for-each (lambda (mod) (dynamic-require mod #f))
modules-to-attach)
(let ([modsyms
(map (lambda (mod) ((current-module-name-resolver) mod #f #f))
modules-to-attach)])
(parameterize ((current-namespace new-ns))
(for-each (lambda (ms) (namespace-attach-module orig-ns ms))
modsyms)))
new-ns))
(define (make-evaluator language teachpacks program-port)
(let ([coverage-enabled (coverage-enabled)]
[uncovered-expressions #f]
[ns (make-evaluation-namespace)]
[orig-ns (current-namespace)])
(parameterize ([current-namespace ns]
[read-case-sensitive #t]
[read-decimal-as-inexact #f]
[current-inspector (make-inspector)])
(parameterize ([current-eventspace (make-eventspace)])
(let ([ch (make-channel)]
[result-ch (make-channel)])
(queue-callback
(lambda ()
;; First read program and evaluate it as a module:
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
(let* ([body
(parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f])
(let loop ([l null])
(let ([expr (read-syntax 'program program-port)])
(if (eof-object? expr)
(reverse l)
(loop (cons expr l))))))]
[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)])])
(when coverage-enabled
(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 coverage-enabled
(set! uncovered-expressions
(filter (lambda (x) (eq? 'program (syntax-source x)))
(safe-eval '(get-uncovered-expressions)
ns)))))
(channel-put result-ch 'ok))
;; Now wait for interaction expressions:
(let loop ()
(let ([expr (channel-get ch)])
(unless (eof-object? expr)
(with-handlers ([void (lambda (exn)
(channel-put result-ch
(cons 'exn exn)))])
(channel-put result-ch (cons 'val (safe-eval expr))))
(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 . more)
(if (pair? more)
(case (car more)
[(uncovered-expressions) uncovered-expressions]
[else (error 'make-evaluator
"Bad arguments: ~e"
(cons expr more))])
(begin (channel-put ch expr)
(let ([r (channel-get result-ch)])
(if (eq? (car r) 'exn)
(raise (cdr r))
(cdr r))))))
;; Program didn't execute:
(raise (cdr r)))))))))
(define (open-input-text-editor/lines str)
(let ([inp (open-input-text-editor str)])
(port-count-lines! inp) inp))
(define (make-evaluator/submission language teachpacks str)
(let-values ([(defs interacts) (unpack-submission str)])
(make-evaluator language teachpacks (open-input-text-editor/lines defs))))
(make-evaluator language teachpacks (open-input-text-editor defs))))
(define (evaluate-all source port eval)
(let loop ()
@ -228,10 +72,9 @@
(define (reraise-exn-as-submission-problem thunk)
(with-handlers ([void (lambda (exn)
(error
(if (exn? exn)
(exn-message exn)
(format "~s" exn))))])
(error (if (exn? exn)
(exn-message exn)
(format "exception: ~e" exn))))])
(thunk)))
;; ----------------------------------------
@ -337,6 +180,6 @@
(define (call-with-evaluator/submission lang teachpacks str go)
(let-values ([(defs interacts) (unpack-submission str)])
(call-with-evaluator lang teachpacks (open-input-text-editor/lines defs) go)))
(call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
)