diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 9a2325cb74..52bbb58add 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -328,6 +328,17 @@ (let ([new (list line)] [cur (thread-cell-ref added-lines)]) (if cur (append! cur new) (thread-cell-set! added-lines new)))) +(define (wrap-evaluator eval) + (lambda (expr) + (current-error-message-tweaker + (lambda (msg) (format "~a, while evaluating ~s" msg expr))) + (begin0 (eval expr) + ;; this will not happen if there was an error, so the above will still be + ;; in -- but the problem is that some evaluations may intentionally raise + ;; exception, so need to clear out this parameter anyway when done with + ;; testing. + (current-error-message-tweaker #f)))) + (provide check:) (define-syntax (check: stx) (define (id s) (datum->syntax-object stx s stx)) @@ -427,7 +438,7 @@ ;; ======================================== ;; verify submitting users (define (pre users submission) - (current-run-status "checking submission username(s)") + (set-run-status "checking submission username(s)") (cond [(list? allowed) (unless (member users allowed) (error* @@ -453,7 +464,7 @@ (define (prefix-line/substs str) (prefix-line (subst str generic-substs))) (define (write-text) - (current-run-status "creating text file") + (set-run-status "creating text file") (with-output-to-file text-file (lambda () (for-each (lambda (user) @@ -467,7 +478,7 @@ 'truncate)) (define submission-text (and create-text? - (begin (current-run-status "reading submission") + (begin (set-run-status "reading submission") ((if multi-file (unpack-multifile-submission names-checker output-file) @@ -477,7 +488,7 @@ (when create-text? (make-directory "grading") (write-text)) (when value-printer (current-value-printer value-printer)) (when coverage? (coverage-enabled #t)) - (current-run-status "checking submission") + (set-run-status "checking submission") (cond [(not eval?) (let () body ...)] [language @@ -501,16 +512,18 @@ (error* "~a" user-error-message)])))]) (call-with-evaluator/submission language teachpacks submission values))]) - (current-run-status "running tests") - (parameterize ([submission-eval eval]) + (set-run-status "running tests") + (parameterize ([submission-eval (wrap-evaluator eval)]) (let-syntax ([with-submission-bindings (syntax-rules () [(_ bindings body*1 body* (... ...)) (with-bindings eval bindings body*1 body* (... ...))])]) (let () body ...)) + ;; see the comment in `wrap-evaluator' for this: + (current-error-message-tweaker #f) ;; test coverage at the end (no harm if already done in - ;; the checker since it's cheap) + ;; the checker since it's cheap): (when coverage? (!all-covered)) (when (thread-cell-ref added-lines) (write-text))))] [else (error* "no language configured for submissions")]) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 416376ae8a..2d4b662278 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -688,8 +688,7 @@ by this function. 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.) + (Note: memory limit requires running in a 3m executable.) > (with-limits sec mb body ...) A macro version of the above. @@ -716,7 +715,7 @@ _utils.ss_ paths, and initial definition content as supplied by input-program (see `make-evaluator'). It also sets the current error-value print handler to print values in a way suitable for `lang', it initializes - `current-run-status' with "executing your code", and it catches all + `set-run-status' with "executing your code", and it catches all exceptions to re-raise them in a form suitable as a submission error. @@ -773,7 +772,7 @@ _utils.ss_ `message'. You can use that to send warnings to the student and wait for confirmation. -> (current-run-status string-or-#f) +> (set-run-status string-or-#f) Registers information about the current actions of the checker, in case the session is terminated due to excessive memory consumption. For example, a checker might set the status to indicate which @@ -959,8 +958,7 @@ Keywords for configuring `check:': This check happens after checker tests are run, but the information is collected and stored before, so checker tests do not change the result. Also, you can use the `!all-covered' procedure in the - checker before other tests, if you want that feedback earlier. Does - not work with non-textual submissions. + checker before other tests, if you want that feedback earlier. Within the body of `check:', `users' and `submission' will be bound to the checker arguments -- a (sorted) list of usernames and the diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 3e32bc3b1b..11f4ad7580 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -631,9 +631,10 @@ ;; Check protocol: (with-handlers ([exn:fail? (lambda (exn) - (let ([msg (if (exn? exn) - (exn-message exn) - (format "~e" exn))]) + (let ([msg (tweak-error-message + (if (exn? exn) + (exn-message exn) + (format "~e" exn)))]) (kill-watcher) (log-line "ERROR: ~a" msg) (write+flush w msg) diff --git a/collects/handin-server/private/run-status.ss b/collects/handin-server/private/run-status.ss index e79548440e..cb5a98d85f 100644 --- a/collects/handin-server/private/run-status.ss +++ b/collects/handin-server/private/run-status.ss @@ -1,15 +1,30 @@ (module run-status mzscheme + + (provide current-run-status-box set-run-status + current-messenger message + current-error-message-tweaker tweak-error-message) + + ;; current-run-status-box is used to let the client know where we are in the + ;; submission process. (define current-run-status-box (make-parameter #f)) - (define (current-run-status s) - (let ([b (current-run-status-box)]) - (when b (set-box! b s) (message s)))) - + ;; current-messenget is a function that will send a message to the client. (define current-messenger (make-parameter #f)) (define (message . args) (let ([messenger (current-messenger)]) (and messenger (apply messenger args)))) - (provide current-run-status-box current-run-status - current-messenger message)) + ;; Set the current-run-status-box and send a message. + (define (set-run-status s) + (let ([b (current-run-status-box)]) + (when b (set-box! b s) (message s)))) + ;; current-error-message-tweaker is a function that is used to change an + ;; error message that is sent to the user. Typical use is to add "while + ;; evaluating ..." to messages. + (define current-error-message-tweaker (make-parameter #f)) + (define (tweak-error-message msg) + (let ([t (current-error-message-tweaker)]) + (if t (t msg) msg))) + + ) diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 3f1846effc..01d26bd960 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -23,9 +23,10 @@ call-with-evaluator call-with-evaluator/submission reraise-exn-as-submission-problem - current-run-status + set-run-status message current-value-printer + current-error-message-tweaker check-proc check-defined @@ -106,8 +107,8 @@ (map (lambda (a) (format " ~e" a)) args)))]) (when (test-history-enabled) (test-history (cons test (test-history)))) - (current-run-status (format "running instructor-supplied test ~a" - (format-history test))) + (set-run-status (format "running instructor-supplied test ~a" + (format-history test))) (let-values ([(ok? val) (with-handlers ([void (lambda (x) @@ -175,7 +176,7 @@ (reraise-exn-as-submission-problem (lambda () (let ([e (make-evaluator lang teachpacks program-port)]) - (current-run-status "executing your code") + (set-run-status "executing your code") (go e)))))) (define (call-with-evaluator/submission lang teachpacks str go)