* 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

@@ -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'
+  given, it can be the symbol 'final, which will be used as the text
-  dialog on the client side, and the resulting value is returned as
+  on the handin dialog after a successful submission (useful for
-  the result of `message'.  You can use that to send warnings to the
+  submissions that were saved, but had problems); finally, `styles'
-  student and wait for confirmation.
+  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.
 

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")
-                 (when create-text?
+                 (define (write-text)
-                   (current-run-status "creating your files on the server")
+                   (with-output-to-file text-file
-                   (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 ()
+                       (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))
+                       (for-each (lambda (l) (printf ";;> ~a\n" l)) extra-lines)
-                                   extra-lines)
+                       (for-each (lambda (l) (printf ";;> ~a\n" l)) added)
-                         (display str)))))
+                       (display submission-text))
+                     'truncate))
+                 (define submission-text
+                   (and create-text?
+                        (submission->string submission maxwidth textualize?)))
+                 (when create-text?
+                   (make-directory "grading")
+                   (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
+                   (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
+                             language teachpacks submission values))])
-                    (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 (... ...))
+                                       [(_ bindings body*1 body* (... ...))
                                         (with-bindings eval bindings
-                                           body1 (... ...))])])
+                                          body*1 body* (... ...))])])
-                          (let () body ...)))))]
+                         (let () body ...))
+                       (when (thread-cell-ref added-lines) (write-text))))]
                   [(not eval?) #t]
                   [else (error* "no language configured for submissions")])
                  output-file)

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)
+                          (if (eq? 'final styles)
-                          (read (make-limited-input-port r 50))])])
+                            (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))