From 76ae386773dfe8b3b88e3795498194acd7cf1150 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2005 17:04:49 +0000 Subject: [PATCH] add support for message on handin accept, fixed minor GUI bug svn: r733 --- collects/handin-client/client.ss | 16 +++- collects/handin-client/tool.ss | 93 +++++++++++-------- collects/handin-server/doc.txt | 74 +++++++-------- collects/handin-server/handin-server.ss | 93 ++++++++----------- .../status-web-root/servlets/status.ss | 52 +++++++---- 5 files changed, 172 insertions(+), 156 deletions(-) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index 7f17ec8e31..3c7fa3d84b 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -55,11 +55,17 @@ (on-commit) (fprintf w "check\n") (flush-output w) - (let ([v (read r)]) - (unless (eq? v 'done) - (error 'handin-connect "commit probably unsucccesful: ~e" v))) - (close-input-port r) - (close-output-port w))) + (let ([result-msg + (let ([v (read r)]) + (cond + [(eq? v 'done) #f] + [(and (pair? v) (eq? (car v) 'result)) + (cadr v)] + [else + (error 'handin-connect "commit probably unsucccesful: ~e" v)]))]) + (close-input-port r) + (close-output-port w) + result-msg))) (define (submit-addition h username full-name id passwd) diff --git a/collects/handin-client/tool.ss b/collects/handin-client/tool.ss index 38019ddd3c..41d28113a5 100644 --- a/collects/handin-client/tool.ss +++ b/collects/handin-client/tool.ss @@ -34,11 +34,15 @@ (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) (define web-address (#%info-lookup 'web-address (lambda () #f))) - (preferences:set-default 'submit:username "" string?) + (define preference-key (string->symbol + (format "submit:username:~a" + this-collection))) + + (preferences:set-default preference-key "" string?) (define (remembered-user) - (preferences:get 'submit:username)) + (preferences:get preference-key)) (define (remember-user user) - (preferences:set 'submit:username user)) + (preferences:set preference-key user)) (define (connect) (handin-connect server @@ -97,26 +101,32 @@ "Handin failed." exn))]) (remember-user (send username get-value)) - (submit-assignment - connection - (send username get-value) - (send passwd get-value) - (send assignment - get-string - (send assignment get-selection)) - content - (lambda () - (semaphore-wait commit-lock) - (send status set-label "Comitting...") - (set! committing? #t) - (semaphore-post commit-lock))) - (queue-callback - (lambda () - (when abort-commit-dialog - (send abort-commit-dialog show #f)) - (send status set-label "Handin successful.") - (set! committing? #f) - (done-interface))))))))] + (let ([result-msg + (submit-assignment + connection + (send username get-value) + (send passwd get-value) + (send assignment + get-string + (send assignment get-selection)) + content + (lambda () + (semaphore-wait commit-lock) + (send status set-label "Comitting...") + (set! committing? #t) + (semaphore-post commit-lock)))]) + (queue-callback + (lambda () + (when abort-commit-dialog + (send abort-commit-dialog show #f)) + (send status set-label "Handin successful.") + (set! committing? #f) + (done-interface) + (when result-msg + (message-box "Handin Result" + result-msg + this + '(ok)))))))))))] [style '(border)])) (define ok-can-enable? #f) @@ -129,17 +139,19 @@ [label "Cancel"] [parent button-panel] [callback (lambda (b e) - (let ([go? (begin - (semaphore-wait commit-lock) - (if committing? - (begin - (semaphore-post commit-lock) - (send abort-commit-dialog show #t) - continue-abort?) - #t))]) - (when go? - (custodian-shutdown-all comm-cust) - (show #f))))])) + (do-cancel-button))])) + (define (do-cancel-button) + (let ([go? (begin + (semaphore-wait commit-lock) + (if committing? + (begin + (semaphore-post commit-lock) + (send abort-commit-dialog show #t) + continue-abort?) + #t))]) + (when go? + (custodian-shutdown-all comm-cust) + (show #f)))) (define continue-abort? #f) (define abort-commit-dialog @@ -182,6 +194,7 @@ (format "~e" exn))] [retry? (regexp-match #rx"bad username or password for" msg)]) (custodian-shutdown-all comm-cust) + (set! committing? #f) (disable-interface) (send status set-label tag) (when (is-shown?) @@ -225,7 +238,7 @@ (define/augment (on-close) (inner (void) on-close) - (custodian-shutdown-all comm-cust)) + (do-cancel-button)) (send ok enable #f) (send assignment enable #f) @@ -449,13 +462,15 @@ [mbm2 (and (send bm get-loaded-mask) (make-object bitmap% (quotient w 2) (quotient h 2)))] [mdc (make-object bitmap-dc% bm2)]) - (send mdc set-scale 0.5 0.5) - (send mdc draw-bitmap bm 0 0) + (send mdc draw-bitmap-section-smooth bm + 0 0 (quotient w 2) (quotient h 2) + 0 0 w h) (send mdc set-bitmap #f) (when mbm2 (send mdc set-bitmap mbm2) - (send mdc set-scale 0.5 0.5) - (send mdc draw-bitmap (send bm get-loaded-mask) 0 0) + (send mdc draw-bitmap-section-smooth (send bm get-loaded-mask) + 0 0 (quotient w 2) (quotient h 2) + 0 0 w h) (send mdc set-bitmap #f) (send bm2 set-loaded-mask mbm2)) bm2)) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 3602a282ee..ca012117f3 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -234,16 +234,21 @@ sub-directories: and the first assignment is the default selection. Within each directory, the student id is used for a sub-directory - name. Within each student sub-directory are "handin.scm" (or some - other name if `default-file-name' is set), "BACKUP-0", "BACKUP-1", - etc., for each student who submits an assignment. (The most recent - handin is in this directory, and "BACKUP-?" directories hold older - submission for the same assignment.) A `checker' procedure can - replace the name "handin.scm" with something else (possibly - sensitive to the content of the submission), and create additional - files; see below for more details. + name. Within each student sub-directory are directories for handin + attempts and successes. If a directory "ATTEMPT" exists, it + contains the most recent (unsuccessful) handin + attempt. Directories "SUCCESS-n" (where n counts from 0) contain + successful handins; the highest numbered such directory represents + the latest handin. - For submissions from a normal DrScheme frame, a "handin.scm" file + Within an "ATTEMPT" or "SUCCESS-n" directory, a file "handin.scm" + (or some other name if `default-file-name' is set) contains the + actual submission. A `checker' procedure can change this default + file name, it can create additional files in an + "ATTEMPT"/"SUCCESS-n" directory or in the student directory; see + below on "checker.ss" for more details. + + For submissions from a normal DrScheme frame, a submission file contains a copy of the student's definitions and interactions windows. The file is in a binary format (to support non-text code), and opening the file directly in DrScheme shows the @@ -251,31 +256,32 @@ sub-directories: parts, the file can be parsed with `unpack-submission' from "utils.ss" (see below). - For submissions from a test-suite window, the file is a normal - test-suite file. - * "inactive/" --- sub-directory for inactive assignments, used by the 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 and the second is the user's - submission as a string. (See also `unpack-submission', etc. from + 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 `checker' function is called when - the current directory is active//, and it can - create additional files in this directory -- such files will get - moved when a backup is done. If you want to hide some of these - files from the web interface, but them in a subdirectory -- it - will be properly backed up, and directories are all hidden from - the web interface. + relayed back to the student. - The checker should return a string, such as "handin.scm", to use in - naming the submission. For submissions that require both programs - and test suites, the checker might use `is-test-suite-submission?' - and return "tests" if the string is a test-suite submission or - "program" if it is not. + The `checker' function is called with the current directory as + "active///ATTEMPT", and the submission is saved + in the file "handin". The checker function can change "handin", + and it can create additional files in this directory or the parent + directory. (Extra files in the current directory will be preserved + as it is later renamed to "SUCCESS-0", etc.) To hide generated + files from the HTTPS status web server interface, put the files in + a subdirectory, which is preserved but hidden from the status + interface. + + The checker should return either a string or a list of two + strings. A single string result, such as "handin.scm", is used to + rename the "handin" submission file. In a list result, the first + string names the submission, and the second string is a + successful-handin message to report back to the student. * "log.ss" (created if not present, appended otherwise) --- records connections and actions, where each entry is of the form @@ -297,9 +303,10 @@ sub-directories: * "[in]active//solution/" --- the solution to the assignment, made available by the status server to any user who - logs in. There must be only one file in "/solution/"; - if there are multiple files, only one named "sol.scm" - is made available as the solution. + logs in. Normall, is the only file in the directory + "/solution/"; if there are multiple files in the + directory, only one named "sol.scm" is made available + as the solution. The server can be run within either MzScheme or MrEd, but "utils.ss" requires MrEd (which means that `checker' modules will likely require @@ -351,17 +358,6 @@ The _utils.ss_ module provides utilities helpful in implementing > (unpack-submission bytes) - returns two text% objects corresponding to the submitted definitions and interactions windows. -> (unpack-test-suite-submission bytes) - returns a pasteboard% - object corresponding to the submitted test-suite window. The - pasteboard contains a sequence of editor-snip% objects, each each - editor-snip% contains a text% with three embedded editor-snip%s: one - for the test expression, one for the expected result, and one for - the equality predicate. - -> (is-test-suite-submission? bytes) - returns #t if `string' can be - read as an old-style test suite, #f otherwise. - - > (make-evaluator language teachpack-paths program-port) - returns a function of one argument for evaluating expressions in the designated teaching language, one of 'beginner, 'beginner-abbr, diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 3c5db3c867..7c616f2f7a 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -62,43 +62,17 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define backup-prefix "BACKUP-") - (define backup-dir-re (regexp (format "^~a[0-9]+$" backup-prefix))) - (define (backup n) (format "~a~a" backup-prefix n)) - (define (files+backups) - (let* ([files (map path->string (directory-list))] - [backups (filter (lambda (f) - (and (directory-exists? f) - (regexp-match backup-dir-re f))) - files)]) - (values (remove* backups files) backups))) - (define (do-backups) - (let-values ([(files backups) (files+backups)]) - (define (make-backup-available n) - (when (member (backup n) backups) - (if (< n MAX-UPLOAD-KEEP) - (begin - (make-backup-available (add1 n)) - (rename-file-or-directory (backup n) (backup (add1 n)))) - (delete-directory/files (backup n))))) - (unless (null? files) - (LOG "backing up ~a" files) - (make-backup-available 0) - (make-directory (backup 0)) - (for-each (lambda (file) - (rename-file-or-directory file (build-path (backup 0) file))) - files)))) - (define (undo-backup) - ;; It is ok to just move BACKUP-0 to the real directory, the above will - ;; just find it available on later backups. - (let-values ([(files backups) (files+backups)]) - (LOG "undoing backup") - (for-each delete-directory/files files) - (when (member (backup 0) backups) - (for-each (lambda (file) - (rename-file-or-directory (build-path (backup 0) file) file)) - (directory-list (backup 0))) - (delete-directory (backup 0))))) + (define ATTEMPT-DIR "ATTEMPT") + (define (success-dir n) + (format "SUCCESS-~a" n)) + (define (make-success-dir-available n) + (let ([name (success-dir n)]) + (when (directory-exists? name) + (if (< n MAX-UPLOAD-KEEP) + (begin + (make-success-dir-available (add1 n)) + (rename-file-or-directory name (success-dir (add1 n)))) + (delete-directory/files name))))) (define (save-submission s part) (with-output-to-file part @@ -129,25 +103,38 @@ "error uploading (got ~e, expected ~s bytes)" (if (bytes? s) (bytes-length s) s) len)) - (do-backups) + ;; Shift successful-attempt directories so that there's + ;; no SUCCESS-0: + (make-success-dir-available 0) + ;; Clear out old ATTEMPT, if any, and make a new one: + (when (directory-exists? ATTEMPT-DIR) + (delete-directory/files ATTEMPT-DIR)) + (make-directory ATTEMPT-DIR) + (save-submission s (build-path ATTEMPT-DIR "handin")) (LOG "checking ~a for ~a" assignment user) - (with-handlers ([void (lambda (e) (undo-backup) (raise e))]) - (let ([part - (let ([checker (build-path 'up "checker.ss")]) - (if (file-exists? checker) - ((dynamic-require `(file ,(path->complete-path checker)) 'checker) - user s) + (let ([part + ;; Result is either a string or list of strings: + (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) + user s))) DEFAULT-FILE-NAME))]) - (fprintf w "confirm\n") + (fprintf w "confirm\n") (flush-output w) - (let ([v (read (make-limited-input-port r 50))]) - (if (eq? v 'check) - (begin - (LOG "saving ~a for ~a" assignment user) - (save-submission s part) - (fprintf w "done\n") - (flush-output w)) - (error 'handin "upload not confirmed: ~s" v)))))))))) + (let ([v (read (make-limited-input-port r 50))]) + (if (eq? v 'check) + (begin + (LOG "saving ~a for ~a" assignment user) + (parameterize ([current-directory ATTEMPT-DIR]) + (rename-file-or-directory "handin" (if (pair? part) (car part) part))) + (rename-file-or-directory ATTEMPT-DIR (success-dir 0)) + (if (pair? part) + (write (list 'result (cadr part)) w) + (fprintf w "done\n")) + (flush-output w)) + (error 'handin "upload not confirmed: ~s" v))))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 3a9904af54..e02f89922d 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -65,13 +65,20 @@ `(a ((href ,(make-k k tag))) ,label)) + (define (find-latest dir) + (let ([zero (build-path dir "SUCCESS-0")]) + (if (directory-exists? zero) + zero + (build-path dir "SUCCESS-1")))) + (define (handin-link k user hi) - (let* ([dir (build-path handin-dir - (if (directory-exists? (build-path handin-dir "active" hi)) - "active" - "inactive") - hi - user)] + (let* ([dir (find-latest + (build-path handin-dir + (if (directory-exists? (build-path handin-dir "active" hi)) + "active" + "inactive") + hi + user))] [l (with-handlers ([exn:fail? (lambda (x) null)]) (parameterize ([current-directory dir]) (filter (lambda (f) @@ -191,23 +198,28 @@ (let ([who (get-status status 'user (lambda () "???"))]) (let-values ([(base name dir?) (split-path tag)]) ;; Any file name is ok... - (unless (path? name) (error "bad1")) + (unless (path? name) (error "bad")) (let-values ([(base name dir?) (split-path base)]) - ;; Directory must be user or "solution" - (unless (or (string=? (path->string name) who) - (string=? (path->string name) "solution")) - (error "bad2")) - ;; Any dir name is ok... + ;; Directory must be SUCCESS-0 or SUCCESS-1 + (unless (or (string=? (path->string name) "SUCCESS-0") + (string=? (path->string name) "SUCCESS-1")) + (error "bad")) (let-values ([(base name dir?) (split-path base)]) - (unless (path? name) (error "bad3")) - ;; Base must be active or inactive + ;; Directory must be user or "solution" + (unless (or (string=? (path->string name) who) + (string=? (path->string name) "solution")) + (error "bad")) + ;; Any dir name is ok... (let-values ([(base name dir?) (split-path base)]) - (unless (or (string=? (path->string name) "active") - (string=? (path->string name) "inactive")) - (error "bad4")) - ;; No more to path - (unless (equal? (build-path base 'same) (build-path handin-dir 'same)) - (error "bad5"))))))) + (unless (path? name) (error "bad")) + ;; Base must be active or inactive + (let-values ([(base name dir?) (split-path base)]) + (unless (or (string=? (path->string name) "active") + (string=? (path->string name) "inactive")) + (error "bad")) + ;; No more to path + (unless (equal? (build-path base 'same) (build-path handin-dir 'same)) + (error "bad")))))))) ;; Return the downloaded file (let ([data (with-input-from-file tag (lambda ()