From e323d152472f17462bf5abfdfa5c0f5fefd85cdb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 9 Oct 2005 00:56:06 +0000 Subject: [PATCH] * Added a (message "..." 'final) that can be used to leave a message when handin is done. * Added `add-header-line' and a `:user-error-message' option to extra-utils.ss svn: r1025 --- collects/handin-server/doc.txt | 48 +++++++++++-- collects/handin-server/extra-utils.ss | 89 +++++++++++++++++-------- collects/handin-server/handin-server.ss | 6 +- 3 files changed, 108 insertions(+), 35 deletions(-) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index cb1770e669..a3d9f1a21e 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -418,7 +418,7 @@ sub-directories: 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 + 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. @@ -605,10 +605,13 @@ The _utils.ss_ module provides utilities helpful in implementing > (message string [styles]) - if given only a string, this string will be shown on the client's submission dialog; if `styles' is also - given, it will be used as a list of styles for a `message-box' - dialog on the client side, and the resulting value is returned as - the result of `message'. You can use that to send warnings to the - student and wait for confirmation. + given, it can be the symbol 'final, which will be used as the text + on the handin dialog after a successful submission (useful for + submissions that were saved, but had problems); finally, `styles' + can be used as a list of styles for a `message-box' dialog on the + client side, and the resulting value is returned as the result of + `message'. You can use that to send warnings to the student and + wait for confirmation. > (current-run-status string-or-#f) - registers information about the current actions of the checker, in case the session is terminated @@ -710,6 +713,36 @@ Keywords for configuring `check:': with a ";;> " prefix too. Defaults to a single line: "Maximum points for this assignment: <+100>". +* :user-error-message -- a string that is used to report an error that + occured during evaluation of the submitted code (not during + additional tests). It can be a plain string which will be used as + the error message, or a string with single a "~a" (or "~e", "~s", + "~v") that will be used as a format string with the actual error + message. Examples of these: + + "there is an error in your program, hit \"Run\" and debug your code" + "There is an error in your program:\n----\n~a\n----\n + Hit \"Run\" and debug your code." + + Alternatively, the value can be a procedure that will be invoked + with the error message. The procedure can do anything it wants, and + if it does not raise an exception, then the checker will proceed as + usual. For example: + + (lambda (msg) + (add-header-line! "Erroneous submission!") + (add-header-line! (format " --> ~a" msg)) + (message (string-append + "You have an error in your program -- please hit" + " \"Run\" and debug your code.\n" + "Email the course staff if you think your code is fine.\n" + "(The submission has been saved but marked as erroneous.)") + '(ok)) + (message "Handin saved as erroneous." 'final)) + + (Note that if you do this, then additional tests should be + adjusted to not raise an exception too.) + * :value-printer -- if specified, this will be used for `current-value-printer' (see above). @@ -789,6 +822,11 @@ value from the submission code. will often try to submit their work alone, and later on re-submit with a partner. +> (add-header-line! line) + During the checker operation, this procedure can be used to add + header lines to the text version of the submitted file. It will not + have an effect if `:create-text?' is false. + > (procedure/arity? proc arity) Returns #t if `proc' is a procedure that accepts `arity' arguments. diff --git a/collects/handin-server/extra-utils.ss b/collects/handin-server/extra-utils.ss index 8384a9b77c..e535fc264e 100644 --- a/collects/handin-server/extra-utils.ss +++ b/collects/handin-server/extra-utils.ss @@ -193,6 +193,13 @@ ;; without this the primitive eval is not available (provide (rename eval prim-eval)) +;; for adding lines in the checker +(define added-lines (make-thread-cell #f)) +(provide add-header-line!) +(define (add-header-line! line) + (let ([new (list line)] [cur (thread-cell-ref added-lines)]) + (if cur (append! cur new) (thread-cell-set! added-lines new)))) + (provide check:) (define-syntax (check: stx) (define (id s) (datum->syntax-object stx s stx)) @@ -225,6 +232,8 @@ [value-printer* (get ':value-printer #'#f)] [coverage?* (get ':coverage? #'#f)] [output* (get ':output #'"hw.scm")] + [user-error-message* + (get ':user-error-message #'"Error in your code --\n~a")] [checker (id 'checker)] [users (id 'users)] [submission (id 'submission)] @@ -259,6 +268,7 @@ [value-printer value-printer*] [coverage? coverage?*] [output-file output*] + [user-error-message user-error-message*] [execute-counts #f]) ;; ======================================== ;; verify submitting users @@ -282,40 +292,63 @@ ;; ======================================== ;; convert to text, evaluate, check (define (check users submission) - (when value-printer (current-value-printer value-printer)) + (define text-file "grading/text.scm") + (define (write-text) + (with-output-to-file text-file + (lambda () + (define added (or (thread-cell-ref added-lines) '())) + (for-each + (lambda (user) + (printf ";;> ~a\n" (user-substs user student-line))) + users) + (for-each (lambda (l) (printf ";;> ~a\n" l)) extra-lines) + (for-each (lambda (l) (printf ";;> ~a\n" l)) added) + (display submission-text)) + 'truncate)) + (define submission-text + (and create-text? + (submission->string submission maxwidth textualize?))) (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 (regexp-match #rx";>" submission-text) + (error* "You cannot use \";>\" in your code!")) + (write-text)) + (when value-printer (current-value-printer value-printer)) (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 ...)))))] + (let ([eval + (with-handlers + ([void + (lambda (e) + (let ([m (if (exn? e) + (exn-message e) + (format "~a" e))]) + (cond + [(procedure? user-error-message) + (user-error-message m)] + [(not (string? user-error-message)) + (error* + "badly configured user-error-message")] + [(regexp-match #rx"~[aesvAESV]" + user-error-message) + (error* user-error-message m)] + [else + (error* "~a" user-error-message)])))]) + (call-with-evaluator/submission + language teachpacks submission values))]) + (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 body*1 body* (... ...)) + (with-bindings eval bindings + body*1 body* (... ...))])]) + (let () body ...)) + (when (thread-cell-ref added-lines) (write-text))))] [(not eval?) #t] [else (error* "no language configured for submissions")]) output-file) diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 0970c89100..cc7daa37d0 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -252,8 +252,10 @@ (case-lambda [(msg) (write+flush w 'message msg)] [(msg styles) - (write+flush w 'message-box msg styles) - (read (make-limited-input-port r 50))])]) + (if (eq? 'final styles) + (write+flush w 'message-final msg) + (begin (write+flush w 'message-box msg styles) + (read (make-limited-input-port r 50))))])]) ;; Clear out old ATTEMPT, if any, and make a new one: (when (directory-exists? ATTEMPT-DIR) (delete-directory/files ATTEMPT-DIR))