diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index ff9ccea974..4f9145c82e 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -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//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///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. diff --git a/collects/handin-server/extra-utils.ss b/collects/handin-server/extra-utils.ss new file mode 100644 index 0000000000..8384a9b77c --- /dev/null +++ b/collects/handin-server/extra-utils.ss @@ -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 stringstring + 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!"))) + +) diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index deac197697..224b576ddf 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -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