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

Added the ability to have pre- and post-checkers.

Browse Source 
Added and documented extra-utils.ss.

svn: r1009
This commit is contained in:
Eli Barzilay 2005-10-07 14:38:09 +00:00
parent b24429088b
commit 6afc5dd4e5
3 changed files with 792 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -279,7 +279,7 @@ sub-directories:
Username that begin with "solution" are special. They are used by
the HTTPS status server. Independent of the 'user-regexp and
'username-case-sensitive? configration items, usernames are not
'username-case-sensitive? configuration items, usernames are not
allowed to contain characters that are illegal in Windows
pathnames, they cannot end or begin in spaces or periods.
@ -365,7 +365,7 @@ sub-directories:
of usernames separated by "+" and any number of spaces (e.g.,
"user1+user2"). The same syntax ("user1+user2") is used for the
directory for shared submissions, and the usernames are always
sorted so that the directory name is deterinistic. Multiple
sorted so that the directory name is deterministic. Multiple
submissions for a particular user in different groups will be
rejected.
@ -373,16 +373,19 @@ sub-directories:
HTTPS status web server.
* "active/<assignment>/checker.ss" (optional) --- a module that
exports a `checker' function. This function receives two
strings. The first is a username list and the second is the
submission as a byte string. (See also `unpack-submission',
etc. from "util.ss", below.) To reject the submission, the
`checker' function can raise an exception; the exception message
will be relayed back to the student.
exports a `checker' function. This function receives two strings.
The first is a username list and the second is the submission as a
byte string. (See also `unpack-submission', etc. from "util.ss",
below.) To reject the submission, the `checker' function can
raise an exception; the exception message will be relayed back to
the student. The module is loaded when the current directory is
the main server directory, so it can read information from
"config.ss".
The first argument is a list of usernames to handle the case of a
joint submission (where the submission username was a
concatenation of usernames separated by "+").
The first argument is a list of usernames with at least one
username, and more than one if this is a joint submission (where
the submission username was a concatenation of usernames separated
by "+").
The `checker' function is called with the current directory as
"active/<assignment>/<username(s)>/ATTEMPT", and the submission is
@ -398,6 +401,28 @@ sub-directories:
The checker should return a string, such as "handin.scm", to use in
naming the submission file.
Alternatively, the module can bind `checker' to a list of three
procedures: a pre-checker, a checker, and a post-checker. All
three are applied in exactly the same way as the checker (same
arguments, and always within the submission directory), except
that:
- If there was an error during the pre-checker, and the submission
directory does not have a "SUCCESS-*" directory, then the whole
submission directory is removed. This is useful for checking
that the user/s are valid -- if you allow a submission only when
`users' is '("foo" "bar"), and "foo" tries to submit alone, then
the submission directory for "foo" should be removed to allow a
proper submission later.
- The post-checker is used at the end of the process, after the
"ATTEMPT" directory was renamed to "SUCCESS-0". At this stage,
the submission is considered successful, so this function should
avoid throwing an exception (it can, but the submission will
still be in place). This is useful for things like notifying
the user of the successful submission (see message below), or
sending a `receipt' email.
To specify only pre/post-checker, use #f for the one you want to
omit.
* "log.ss" (created if not present, appended otherwise) --- records
connections and actions, where each entry is of the form
(id time-str msg-str)
@ -602,3 +627,190 @@ The _utils.ss_ module provides utilities helpful in implementing
> (reraise-exn-as-submission-problem thunk) - calls thunk in a context
that catches exceptions and re-raises them in a form suitable as a
submission error.
Extra Checker Utilities
============================================
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
checker that uses it looks like this:
(module checker (lib "extra-utils.ss" "handin-server")
(check: :language 'intermediate
:users pairs-or-singles-with-warning
:coverage? #t
(!procedure Fahrenheit->Celsius 1)
(!test (Fahrenheit->Celsius 32) 0)
(!test (Fahrenheit->Celsius 212) 100)
(!test (Fahrenheit->Celsius -4) -20)
...
(!all-covered)))
> (check: :key val ... body ...)
Construct a checker procedure.
The `check:' macro will construct an appropriate checker function,
using keywords for features that you want, the body of the checker can
contain arbitrary code, using all utilities from "utils.ss" (see
above), as well as additional ones (see below).
Keywords for configuring `check:':
* :users -- specification of users that are acceptable for
submission. Can be either a list of user lists, each representing a
known team, or procedure which will accept a list of users and throw
an exception if they are unacceptable. The default is to accept
only single-user submissions. `pairs-or-singles-with-warning' is a
useful value for pair submission where the pairs are unknown (see
below).
* :eval? -- whether submissions should be evaluated. Defaults to #t.
* :language -- the language that is used for evaluating submissions,
same as the `language' argument for `make-evaluator' (see above).
There is no default for this, so it must be set or an error is
raised.
* :teachpacks -- teachpacks for evaluating submissions, same as the
`teachpacks' argument for `make-evaluator' (see above). Defaults to
null -- no teachpacks.
* :create-text? -- if true, then a textual version of the submission
is saved as `text.scm' in a `grading' subdirectory. This is
intended for printouts and grading, and is in a subdirectory so
students will not see it on the status web server. Defaults to #t.
* :textualize? -- if true, then all submissions are converted to text,
trying to convert objects like comment boxes and test cases to some
form of text. Defaults to #f, meaning that an exception is raised
for submissions that are not all text.
* :maxwidth -- a number that specifies maximum line lengths for
submissions (a helpful feature for reading student code). Defaults
to 80. This feature can be disabled if set to #f.
* :output -- the name of the original handin file (unrelated to the
text-converted files). Defaults to "hw.scm".
* :student-line -- when a submission is converted to text, it begins
with lines describing the students that have submitted it; this is
used to specify the format of these lines. It is a string with
holes that that `user-substs' (see below) fills out. The default is
"Student: {username} ({Full Name} <{Email}>)", which requires a
"Full Name" and "Email" entries in the server's extra-fields
configuration. These lines are always prefixed with ";;> ".
* :extra-lines -- a list of lines to add after the student lines, all
with a ";;> " prefix too. Defaults to a single line: "Maximum
points for this assignment: <+100>".
* :value-printer -- if specified, this will be used for
`current-value-printer' (see above).
* :coverage? -- collect coverage information when evaluating the
submission (not including additional checker tests). This is needed
for the `!all-covered' procedure below. Does not work with
non-textual submissions.
Within the body of `check:', `users' and `submission' will be bound to
the checker arguments -- a (sorted) list of usernames and the
submission as a byte string. In addition to the functionality below,
you can use `((submission-eval) expr)' to evaluate expressions in the
submitted code context, and you can use `(with-submission-bindings (id
...) body ...)' to evaluate the body when `id's are bound to their
value from the submission code.
> (pre: body ...)
> (post: body ...)
These two macros define a pre- and a post-checker. In their body,
`users' and `submission' are bound as in `check:', but there is
nothing else special about these. See the description of the
`pre-checker' and `post-checker' values for what can be done with
these, and note that the check for valid users is always first.
> submission-eval
A parameter that holds an evaluation procedure for evaluating code
in the submission context.
> (user-data user)
Returns a user information given a username. The returned
information is a list of strings that corresponds to the configured
`extra-fields' (see above).
> (user-substs user str)
Given a username, this procedure will lookup the user's extra-fields
information (see above) and then substitute field names in {braces}
by the corresponding value. An error will be signaled if a field
name is missing. Also, "{username}" will always be replaced by the
username.
This is used to process the `:student-line' value in the checker,
but it is provided for additional uses. For example, the following
is an example of a post-checker that will send a submission receipt
email with CC to the TA (assuming a single TA), and pop-up a message
telling the student about it:
(require (lib "sendmail.ss" "net"))
(post:
(send-mail-message
"cour-staff@university.edu
"Submission Receipt"
(map (lambda (user) (user-substs user "{Full Name} <{Email}>"))
users)
(list (user-substs (first users) "{TA Name} <{TA Email}>"))
null
(list "Your submission was received"
... provide details on hw.scm ...))
(message (string-append
"Your submission was successfully saved."
" You will get an email receipt within 30 minutes;"
" if not, please contact the course staff.")
'(ok)))
> (pairs-or-singles-with-warning users)
This procedure is intended for use as the :users entry in a checker.
It will do nothing if there are two users, and throw an error if
there are more. If there is a single user, then the user will be
asked to verify a single submission -- if the students cancels, then
an exception is raised so the submission directory is retracted. If
the student approves this, the question is not repeated (this is
marked by creating a directory with a known name). This is useful
for cases where you want to allow free pair submissions -- students
will often try to submit their work alone, and later on re-submit
with a partner.
> (procedure/arity? proc arity)
Returns #t if `proc' is a procedure that accepts `arity' arguments.
> (!defined id ...)
A macro that checks that the given identifiers are defined in the
(evaluated) submission, and throws an error otherwise.
> (!procedure id [arity])
> (!procedure* expr [arity])
`!procedure' checks that `id' is defined, and is bound to a
procedure; `!*procedure' is similar but omits the defined check,
making it usable with any expression (which is evaluated in the
submission context).
> (!integer id)
> (!integer* expr)
Similar to `!procedure' and `!procedure*' for integers.
> (!test expr)
> (!test expr result [equal?])
The first form checks that the given expression evaluates to a
non-#f value in the submission context, throwing an error
otherwise. The second form compares the result of evaluation,
requiring it to be equal to `result' (optionally specifying an
equality procedure).
> (!all-covered)
When coverage information is enabled (see `:coverage?' above), this
procedure checks the collected coverage information and throws an
error with source information if some code is left uncovered. The
collected information includes only execution coverage by submission
code, excluding additional checker tests.

517
collects/handin-server/extra-utils.ss Normal file
View File

@ -0,0 +1,517 @@
(module extra-utils mzscheme
(require (lib "utils.ss" "handin-server")
(lib "file.ss") (lib "list.ss") (lib "class.ss")
(lib "mred.ss" "mred"))
(provide (all-from-except mzscheme #%module-begin)
(all-from (lib "utils.ss" "handin-server")))
(provide (rename module-begin~ #%module-begin))
(define-syntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(with-syntax ([user-pre (datum->syntax-object stx 'user-pre stx)]
[user-post (datum->syntax-object stx 'user-post stx)])
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object stx (quote-syntax (provide checker)))
#'(define user-pre #f)
#'(define user-post #f)
(cdr e))
stx))
(raise-syntax-error #f "bad syntax" stx))))
(define server-dir (current-directory))
(define (error* fmt . args)
(error (apply format fmt args)))
(define fields
(map car (get-preference 'extra-fields (lambda () #f) #f
(build-path server-dir "config.ss"))))
(provide user-data)
(define (user-data user)
;; the student always assumed to exist
(cdr (get-preference (if (string? user) (string->symbol user) user)
(lambda () #f) #f (build-path server-dir "users.ss"))))
(provide user-substs)
(define (user-substs user str)
(subst str `(("username" . ,user) ,@(map cons fields (user-data user)))))
(define (subst str substs)
(if (list? str)
(map (lambda (x) (subst x substs)) str)
(let* ([m (regexp-match-positions #rx"{([^{}]+)}" str)]
[s (and m (substring str (caadr m) (cdadr m)))])
(if m
(subst (string-append (substring str 0 (caar m))
(cond [(assoc s substs) => cdr]
[else (error 'subst
"unknown substitution: ~s" s)])
(substring str (cdar m)))
substs)
str))))
(define (verify-line-length line n len)
(define (string-width str)
(let loop ([l (string->list str)] [w 0])
(if (null? l)
w
(loop (cdr l)
(if (char=? #\tab (car l)) (+ 8 (- w (modulo w 8))) (add1 w))))))
(unless (< (bytes-length line) len)
(let ([line (bytes->string/utf-8 line)])
(unless (or (< (string-length line) len)
(< (string-width line) len))
(error* "~a \"~a\" is longer than ~a characters"
(if n (format "Line #~a" n) "The line")
(regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1")
len)))))
;; ============================================================================
;; Text conversion
;; Code that turns binary stuff into text is split into three places:
;; * input-port->text-input-port implements a simple generic textualization
;; filter
;; * snip->text is used earlier in the process, where comment-box text is still
;; available
;; * test-boxes are registered through some hacked up code that will turn them
;; into an editor% with text that input-port->text-input-port will then spit
;; out.
(require (lib "framework.ss" "framework")) ; for drscheme snips, used below
;; input-port->text-input-port : input-port (any -> any) -> input-port
;; the `filter' function is applied to special values; the filter result is
;; `display'ed into the stream in place of the special
(define (input-port->text-input-port src . filter)
;; note that snip->text below already takes care of some snips
(define (item->text x)
(cond [(is-a? x snip%)
(format "{{~a}}" (or (send x get-text 0 (send x get-count) #t) x))]
[(special-comment? x)
(format "#| ~a |#" (special-comment-value x))]
[else x]))
(let-values ([(filter) (if (pair? filter) (car filter) item->text)]
[(in out) (make-pipe 4096)])
(thread
(lambda ()
(let ([s (make-bytes 4096)])
(let loop ()
(let ([c (read-bytes-avail! s src)])
(cond [(number? c) (write-bytes s out 0 c) (loop)]
[(procedure? c)
(let ([v (let-values ([(l col p) (port-next-location src)])
(c (object-name src) l col p))])
(display (filter v) out))
(loop)]
[else (close-output-port out)])))))) ; Must be EOF
in))
(define (snip->text x)
(let ([name (and (is-a? x snip%)
(send (send x get-snipclass) get-classname))])
(cond [(equal? name "wximage") "{{IMAGE}}"]
[(equal? name "(lib \"comment-snip.ss\" \"framework\")")
;; comments will have ";" prefix on every line, and "\n" suffix
(format ";{{COMMENT:\n~a;}}\n"
(send x get-text 0 (send x get-count)))]
[else x])))
(define (submission->string submission maxwidth textualize?)
(let-values ([(defs inters) (unpack-submission submission)])
(parameterize ([current-output-port (open-output-string)]
[current-input-port
(if textualize?
(input-port->text-input-port
(open-input-text-editor defs 0 'end snip->text))
(open-input-text-editor defs))])
(let loop ([n 1])
(let ([line (if textualize?
(read-bytes-line)
(with-handlers ([void
(lambda (e)
(error* "The submission must not ~a"
"have non-textual items"))])
(read-bytes-line)))])
(unless (eof-object? line)
(let ([line (regexp-replace #rx#"[ \t]+$" line #"")])
(when maxwidth
(verify-line-length line (and (not textualize?) n) maxwidth))
(display line) (newline) (loop (add1 n))))))
(get-output-string (current-output-port)))))
;; ---------------------------------------------
;; This code will hack test boxes textualization
(define test-sc
(new (class snip-class%
(define/override (read f)
(let ([test (new test%)]) (send test read-from-file f) test))
(super-new))))
(define test%
(class editor-snip%
(inherit set-snipclass get-editor)
(define to-test (new text%))
(define expected (new text%))
(define predicate (new text%))
(define should-raise (new text%))
(define error-message (new text%))
(define/public (read-from-file f)
(unless (eq? 2 (send test-sc reading-version f)) (error "BOOM"))
(send to-test read-from-file f)
(send expected read-from-file f)
(send predicate read-from-file f)
(send should-raise read-from-file f)
(send error-message read-from-file f)
(send f get (box 0)) ; enabled?
(send f get (box 0)) ; collapsed?
(send f get (box 0))) ; error-box
(super-new)
(set-snipclass test-sc)
(for-each (lambda (x)
(send (get-editor)
insert (if (string? x) x (make-object editor-snip% x))))
(list "TEST:\n"
" expression: " to-test "\n"
" should be: " expected "\n"))))
(send test-sc set-classname "test-case-box%")
(send test-sc set-version 2)
(send (get-the-snip-class-list) add test-sc)
;; ============================================================================
;; Checker function
(provide submission-eval)
(define submission-eval (make-parameter #f))
;; without this the primitive eval is not available
(provide (rename eval prim-eval))
(provide check:)
(define-syntax (check: stx)
(define (id s) (datum->syntax-object stx s stx))
(let loop ([stx (syntax-case stx () [(_ x ...) #'(x ...)])]
[keyvals '()])
(define (get key . default)
(cond [(assq key keyvals) => (lambda (x) (set-car! x #f) (caddr x))]
[(pair? default) (car default)]
[else #f]))
(syntax-case stx ()
[(key val x ...)
(and (identifier? #'key)
(regexp-match #rx"^:" (symbol->string (syntax-e #'key))))
(loop #'(x ...) (cons (list (syntax-e #'key) #'key #'val) keyvals))]
[(body ...)
(with-syntax
([users* (get ':users #'#f)]
[eval?* (get ':eval? #'#t)]
[language* (get ':language #'#f)]
[teachpacks* (get ':teachpacks #''())]
[create-text?* (get ':create-text? #'#t)]
[textualize?* (get ':textualize? #'#f)]
[maxwidth* (get ':maxwidth #'80)]
[student-line*
(get ':student-line
#'"Student: {username} ({Full Name} <{Email}>)")]
[extra-lines*
(get ':extra-lines
#''("Maximum points for this assignment: <+100>"))]
[value-printer* (get ':value-printer #'#f)]
[coverage?* (get ':coverage? #'#f)]
[output* (get ':output #'"hw.scm")]
[checker (id 'checker)]
[users (id 'users)]
[submission (id 'submission)]
[eval (id 'eval)]
[execute-counts (id 'execute-counts)]
[with-submission-bindings (id 'with-submission-bindings)]
[user-pre (id 'user-pre)]
[user-post (id 'user-post)]
[(body ...) (syntax-case #'(body ...) ()
[() #'(void)] [_ #'(body ...)])])
(for-each (lambda (x)
(when (car x)
(raise-syntax-error #f "unknown keyword" stx (cadr x))))
keyvals)
#'(define checker
(let ([allowed (let ([us users*])
(if (list? us)
(map (lambda (x)
(if (list? x)
(quicksort x string<?)
(list x)))
us)
us))]
[eval? eval?*]
[language language*]
[teachpacks teachpacks*]
[create-text? create-text?*]
[textualize? textualize?*]
[maxwidth maxwidth*]
[student-line student-line*]
[extra-lines extra-lines*]
[value-printer value-printer*]
[coverage? coverage?*]
[output-file output*]
[execute-counts #f])
;; ========================================
;; verify submitting users
(define (pre users submission)
(current-run-status "checking submission username(s)")
(cond [(list? allowed)
(unless (member users allowed)
(error*
"You are not registered ~a for this submission"
(case (length users)
[(1) "for individual submission"]
[(2) "as a pair"]
[else "as a group"])))]
[(procedure? allowed) (allowed users)]
[(not allowed) ; default is single-user submission
(unless (= 1 (length users))
(error*
"This homework is for individual submissions"))]
[else (error* "bad user specifications")])
(when user-pre (user-pre users submission)))
;; ========================================
;; convert to text, evaluate, check
(define (check users submission)
(when value-printer (current-value-printer value-printer))
(when create-text?
(current-run-status "creating your files on the server")
(make-directory "grading")
(let ([str (submission->string
submission maxwidth textualize?)])
(when (regexp-match #rx";>" str)
(error* "You cannot use \";>\" in your code!"))
(with-output-to-file "grading/text.scm"
(lambda ()
(for-each
(lambda (user)
(printf ";;> ~a\n" (user-substs user student-line)))
users)
(for-each (lambda (l) (printf ";;> ~a\n" l))
extra-lines)
(display str)))))
(when coverage? (coverage-enabled #t))
(current-run-status "checking submission")
(cond
[language
(call-with-evaluator/submission
language teachpacks submission
(lambda (eval)
(when coverage?
(set! execute-counts (eval #f 'execute-counts)))
(current-run-status "running tests")
(parameterize ([submission-eval eval])
(let-syntax ([with-submission-bindings
(syntax-rules ()
[(_ bindings body1 (... ...))
(with-bindings eval bindings
body1 (... ...))])])
(let () body ...)))))]
[(not eval?) #t]
[else (error* "no language configured for submissions")])
output-file)
;; ========================================
;; configuration sanity checks
(let ([bad (cond [(and eval? (not language))
"`eval?' without `language'"]
[(and (not create-text?) textualize?)
"`textualize?' without `create-text?'"]
[(and (not eval?) coverage?)
"`coverage?' without `eval?'"]
[(and textualize? coverage?)
"`textualize?' and `coverage?'"]
[else #f])])
(when bad
(error* "bad checker specifications: cannot use ~a" bad)))
;; ========================================
(list pre check user-post))))])))
(define-syntax (with-bindings stx)
(syntax-case stx ()
[(_ get (var ...) body ...)
(with-syntax ([(>var ...)
(map (lambda (v)
(datum->syntax-object
v
(string->symbol
(string-append
"~" (symbol->string (syntax-e v))))
v))
(syntax->list #'(var ...)))])
#'(let ([>var (get 'var)] ...) body ...))]))
;; Similar utilities for pre- and post-checkers
(provide pre: post:)
(define-syntaxes (pre: post:)
(let ([make-pre/post:
(lambda (what)
(lambda (stx)
(define (id s) (datum->syntax-object stx s stx))
(syntax-case stx ()
[(_ body ...)
(with-syntax ([users (id 'users)]
[submission (id 'submission)]
[what (id what)])
#'(set! what (lambda (users submission) body ...)))])))])
(values (make-pre/post: 'user-pre) (make-pre/post: 'user-post))))
;; ============================================================================
;; User-checker utilities
;; To verify single submissions, we use a "wants-single-submission" directory
;; in the user's main submission directory to mark if already verified. If the
;; users regrets the submission, the *whole* directory is removed. This
;; assumes that there is nothing there, so this check should not be added after
;; submission has already began since students may lose work.
(define (warn-single user)
;; we're in ATTEMPT, climb up to the main directory
(parameterize ([current-directory ".."])
(unless (directory-exists? "wants-single-submission")
(if (eq? 'yes
(message
(string-append
"You have chosen to submit your work individually;"
" if you continue, it will be impossible for you to"
" later submit with a partner. Are you sure you want"
" to continue?"
(path->string (current-directory)))
'(yes-no)))
(make-directory "wants-single-submission")
(error* "Aborting single submission!")))))
(provide pairs-or-singles-with-warning)
(define (pairs-or-singles-with-warning users)
(case (length users)
[(2) #t]
[(1) (warn-single (car users))]
[else (error* "too many users in the team: ~a" users)]))
;; ============================================================================
;; Checker utilities
(define (->disp x)
(cond [(pair? x)
(if (and (eq? 'unquote (car x)) (= 2 (length x)))
(->disp (cadr x))
(cons (->disp (car x)) (->disp (cdr x))))]
[(not (symbol? x)) x]
[else (regexp-replace "^~" (symbol->string x) "") x]))
(provide procedure/arity?)
(define (procedure/arity? proc arity)
(and (procedure? proc) (procedure-arity-includes? proc arity)))
(provide !defined)
(define-syntax !defined
(syntax-rules ()
;; expected to be used only with identifiers
[(_ id ...) (begin (with-handlers
([exn:fail:contract:variable?
(lambda (_)
(error* "missing binding: ~a" (->disp 'id)))])
((submission-eval) `id))
...)]))
(provide !procedure* !procedure)
(define-syntax !procedure*
(syntax-rules ()
[(_ expr)
(unless (procedure? ((submission-eval) `expr))
(error* "~a is expected to be bound to a procedure" (->disp 'expr)))]
[(_ expr arity)
(let ([ar arity]
[val ((submission-eval) `expr)])
(unless (procedure? val)
(error* "~a is expected to be bound to a procedure" (->disp 'expr)))
(unless (procedure-arity-includes? val ar)
(error* "~a is expected to be bound to a procedure of ~s arguments"
(->disp 'expr) ar)))]))
(define-syntax !procedure
(syntax-rules ()
[(_ expr) (begin (!defined expr) (!procedure* expr))]
[(_ expr arity) (begin (!defined expr) (!procedure* expr arity))]))
(provide !integer* !integer)
(define-syntax !integer*
(syntax-rules ()
[(_ expr)
(unless (integer? ((submission-eval) `expr))
(error* "~a is expected to be bound to an integer" (->disp 'expr)))]))
(define-syntax !integer
(syntax-rules ()
[(_ expr) (begin (!defined expr) (!integer* expr))]))
(provide !test)
(define-syntax !test
(syntax-rules ()
[(_ expr)
(unless ((submission-eval) `expr)
(error* "your code failed a test: ~a is false" (->disp 'expr)))]
[(_ expr result) (!test expr result equal?)]
[(_ expr result equal?)
(let ([val ((submission-eval) `expr)])
(unless (equal? result val)
(error*
"your code failed a test: ~a evaluated to ~a, expecting ~a"
(->disp 'expr) (->disp val) (->disp result))))]))
(provide !all-covered)
(define (!all-covered)
(define execute-counts ((submission-eval) #f 'execute-counts))
(define (coverage-error stx)
(error* "your code is not completely covered by test cases~a"
(cond [(and (syntax-line stx) (syntax-column stx))
(format ": uncovered expression at ~a:~a"
(syntax-line stx) (syntax-column stx))]
[(syntax-position stx)
(format ": uncovered expression at position ~a"
(syntax-position stx))]
[else ""])))
(if execute-counts
#|
;; Go over all counts that are syntax-original, avoiding code that macros
;; insert
(for-each (lambda (x)
(when (and (zero? (cdr x)) (syntax-original? (car x)))
(coverage-error (car x))))
execute-counts)
|#
;; Better: try to find if there is some source position that is not
;; covered, if so, it means that there is some macro that originates in
;; some real source position that is not covered. Also, return the first
;; one found of the biggest span (so an error will point at `(+ 1 2)', not
;; on the `+').
(let ([table (make-hash-table)])
(for-each
(lambda (x)
(let* ([loc (syntax-position (car x))]
[h (hash-table-get table loc (lambda () #f))])
(when (or (not h) (< (cdr h) (cdr x)))
(hash-table-put! table loc x))))
execute-counts)
(let ([1st #f])
(hash-table-for-each table
(lambda (key val)
(when (and (zero? (cdr val))
(or (not 1st)
(let ([car-pos (syntax-position (car val))]
[1st-pos (syntax-position 1st)])
(or (< car-pos 1st-pos)
(and (= car-pos 1st-pos)
(> (syntax-span (car val))
(syntax-span 1st)))))))
(set! 1st (car val)))))
(when 1st (coverage-error 1st))))
(error* "mis-configuration: requires coverage, but no coverage info!")))
)

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

@ -42,8 +42,14 @@
(display line log-port)
(flush-output log-port)))
(define server-dir (current-directory))
(define config-file (build-path server-dir "config.ss"))
(unless (file-exists? config-file)
(error 'handin-server
"must be started from a properly configured directory"))
(define (get-config which default)
(get-preference which (lambda () default) #f "config.ss"))
(get-preference which (lambda () default) #f config-file))
(define PORT-NUMBER (get-config 'port-number 7979))
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
@ -253,26 +259,52 @@
(make-directory ATTEMPT-DIR)
(save-submission s (build-path ATTEMPT-DIR "handin"))
(LOG "checking ~a for ~a" assignment users)
(let ([part (let ([checker (build-path 'up "checker.ss")])
(if (file-exists? checker)
(let ([checker (path->complete-path checker)])
(parameterize ([current-directory ATTEMPT-DIR])
((dynamic-require checker 'checker)
users s)))
DEFAULT-FILE-NAME))])
(current-messenger #f) ; no messages at this stage
(write+flush w 'confirm)
(let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check)
(begin
(LOG "saving ~a for ~a" assignment users)
(let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
[checker* (and (file-exists? checker*)
(parameterize ([current-directory server-dir])
(dynamic-require checker* 'checker)))])
(define-values (pre checker post)
(cond [(not checker*) (values #f #f #f)]
[(procedure? checker*) (values #f checker* #f)]
[(and (list? checker*) (= 3 (length checker*)))
(apply values checker*)]
[else (error 'handin-configuration
"bad checker value: ~e" checker*)]))
(when pre
(let ([dir (current-directory)])
(with-handlers
([void (lambda (e)
(parameterize ([current-directory dir])
(unless (ormap
(lambda (d)
(and (directory-exists? d)
(regexp-match SUCCESS-RE d)))
(map path->string (directory-list)))
(parameterize ([current-directory ".."])
(when (directory-exists? dirname)
(delete-directory/files dirname)))))
(raise e))])
(parameterize ([current-directory ATTEMPT-DIR])
(rename-file-or-directory "handin" part))
;; Shift successful-attempt directories so that there's
;; no SUCCESS-0:
(make-success-dir-available 0)
(rename-file-or-directory ATTEMPT-DIR (success-dir 0)))
(error 'handin "upload not confirmed: ~s" v))))))))
(pre users s)))))
(let ([part (if checker
(parameterize ([current-directory ATTEMPT-DIR])
(checker users s))
DEFAULT-FILE-NAME)])
(write+flush w 'confirm)
(let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check)
(begin
(LOG "saving ~a for ~a" assignment users)
(parameterize ([current-directory ATTEMPT-DIR])
(rename-file-or-directory "handin" part))
;; Shift successful-attempt directories so that there's
;; no SUCCESS-0:
(make-success-dir-available 0)
(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
(when post
(parameterize ([current-directory (success-dir 0)])
(post users s))))
(error 'handin "upload not confirmed: ~s" v)))))))))
(define (retrieve-specific-submission data w)
;; Note: users are always sorted