add support for message on handin accept, fixed minor GUI bug

svn: r733

collects/handin-client/client.ss

@@ -55,11 +55,17 @@
       (on-commit)
       (fprintf w "check\n")
       (flush-output w)
-      (let ([v (read r)])
+      (let ([result-msg 
-	(unless (eq? v 'done)
+	     (let ([v (read r)])
-	  (error 'handin-connect "commit probably unsucccesful: ~e" v)))
+	       (cond
-      (close-input-port r)
+		[(eq? v 'done) #f]
-      (close-output-port w)))
+		[(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)

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
+					 (let ([result-msg
-					  connection
+						(submit-assignment
-					  (send username get-value)
+						 connection
-					  (send passwd get-value)
+						 (send username get-value)
-					  (send assignment
+						 (send passwd get-value)
-						get-string
+						 (send assignment
-						(send assignment get-selection))
+						       get-string
-					  content
+						       (send assignment get-selection))
-					  (lambda ()
+						 content
-					    (semaphore-wait commit-lock)
+						 (lambda ()
-					    (send status set-label "Comitting...")
+						   (semaphore-wait commit-lock)
-					    (set! committing? #t)
+						   (send status set-label "Comitting...")
-					    (semaphore-post commit-lock)))
+						   (set! committing? #t)
-					 (queue-callback
+						   (semaphore-post commit-lock)))])
-					  (lambda ()
+					   (queue-callback
-					    (when abort-commit-dialog
+					    (lambda ()
-					      (send abort-commit-dialog show #f))
+					      (when abort-commit-dialog
-					    (send status set-label "Handin successful.")
+						(send abort-commit-dialog show #f))
-					    (set! committing? #f)
+					      (send status set-label "Handin successful.")
-					    (done-interface))))))))]
+					      (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
+				       (do-cancel-button))]))
-						    (semaphore-wait commit-lock)
+      (define (do-cancel-button)
-						    (if committing?
+	(let ([go? (begin
-							(begin
+		     (semaphore-wait commit-lock)
-							  (semaphore-post commit-lock)
+		     (if committing?
-							  (send abort-commit-dialog show #t)
+			 (begin
-							  continue-abort?)
+			   (semaphore-post commit-lock)
-							#t))])
+			   (send abort-commit-dialog show #t)
-					 (when go?
+			   continue-abort?)
-					   (custodian-shutdown-all comm-cust)
+			 #t))])
-					   (show #f))))]))
+	  (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-section-smooth bm 
-      (send mdc draw-bitmap bm 0 0)
+	    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-section-smooth (send bm get-loaded-mask)
-	(send mdc draw-bitmap (send bm get-loaded-mask) 0 0)
+	      0 0 (quotient w 2) (quotient h 2)
+	      0 0 w h)
 	(send mdc set-bitmap #f)
 	(send bm2 set-loaded-mask mbm2))
       bm2))

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
+    name. Within each student sub-directory are directories for handin
-    other name if `default-file-name' is set), "BACKUP-0", "BACKUP-1",
+    attempts and successes. If a directory "ATTEMPT" exists, it
-    etc., for each student who submits an assignment. (The most recent
+    contains the most recent (unsuccessful) handin
-    handin is in this directory, and "BACKUP-?" directories hold older
+    attempt. Directories "SUCCESS-n" (where n counts from 0) contain
-    submission for the same assignment.) A `checker' procedure can
+    successful handins; the highest numbered such directory represents
-    replace the name "handin.scm" with something else (possibly
+    the latest handin.
-    sensitive to the content of the submission), and create additional
-    files; see below for more details.
 
-    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/<assignment>/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
+    relayed back to the student.
-    the current directory is active/<assignment>/<user>, 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.
 
-    The checker should return a string, such as "handin.scm", to use in
+    The `checker' function is called with the current directory as
-    naming the submission. For submissions that require both programs
+    "active/<assignment>/<user>/ATTEMPT", and the submission is saved
-    and test suites, the checker might use `is-test-suite-submission?'
+    in the file "handin". The checker function can change "handin",
-    and return "tests" if the string is a test-suite submission or
+    and it can create additional files in this directory or the parent
-    "program" if it is not.
+    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/<assignment>/solution/<file>" --- the solution to the
     assignment, made available by the status server to any user who
-    logs in. There must be only one file in "<assignment>/solution/";
+    logs in. Normall, <file> is the only file in the directory
-    if there are multiple files, only one named "<assignment>sol.scm"
+    "<assignment>/solution/"; if there are multiple files in the
-    is made available as the solution.
+    directory, only one named "<assignment>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,

collects/handin-server/handin-server.ss

@@ -62,43 +62,17 @@
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-  (define backup-prefix "BACKUP-")
+  (define ATTEMPT-DIR "ATTEMPT")
-  (define backup-dir-re (regexp (format "^~a[0-9]+$" backup-prefix)))
+  (define (success-dir n) 
-  (define (backup n) (format "~a~a" backup-prefix n))
+    (format "SUCCESS-~a" n))
-  (define (files+backups)
+  (define (make-success-dir-available n)
-    (let* ([files (map path->string (directory-list))]
+    (let ([name (success-dir n)])
-           [backups (filter (lambda (f)
+      (when (directory-exists? name)
-			      (and (directory-exists? f)
+	(if (< n MAX-UPLOAD-KEEP)
-				   (regexp-match backup-dir-re f)))
+	    (begin 
-			    files)])
+	      (make-success-dir-available (add1 n))
-      (values (remove* backups files) backups)))
+	      (rename-file-or-directory name (success-dir (add1 n))))
-  (define (do-backups)
+	    (delete-directory/files name)))))
-    (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 (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 ([part
+		   ;; Result is either a string or list of strings:
-                     (let ([checker (build-path 'up "checker.ss")])
+		   (let ([checker (build-path 'up "checker.ss")])
-                       (if (file-exists? checker)
+		     (if (file-exists? checker)
-			 ((dynamic-require `(file ,(path->complete-path checker)) 'checker)
+			 (let ([checker (path->complete-path checker)])
-			  user s)
+			   (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))])
+		(let ([v (read (make-limited-input-port r 50))])
-                  (if (eq? v 'check)
+		  (if (eq? v 'check)
-		    (begin
+		      (begin
-		      (LOG "saving ~a for ~a" assignment user)
+			(LOG "saving ~a for ~a" assignment user)
-		      (save-submission s part)
+			(parameterize ([current-directory ATTEMPT-DIR])
-		      (fprintf w "done\n")
+			  (rename-file-or-directory "handin" (if (pair? part) (car part) part)))
-		      (flush-output w))
+			(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
-		    (error 'handin "upload not confirmed: ~s" v))))))))))
+			(if (pair? part)
+			    (write (list 'result (cadr part)) w)
+			    (fprintf w "done\n"))
+			(flush-output w))
+		      (error 'handin "upload not confirmed: ~s" v)))))))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

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
+	(let* ([dir (find-latest
-				(if (directory-exists? (build-path handin-dir "active" hi))
+		     (build-path handin-dir
-				    "active"
+				 (if (directory-exists? (build-path handin-dir "active" hi))
-				    "inactive")
+				     "active"
-				hi
+				     "inactive")
-				user)]
+				 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"
+		;; Directory must be SUCCESS-0 or SUCCESS-1
-		(unless (or (string=? (path->string name) who)
+		(unless (or (string=? (path->string name) "SUCCESS-0")
-			    (string=? (path->string name) "solution"))
+			    (string=? (path->string name) "SUCCESS-1"))
-		  (error "bad2"))
+		  (error "bad"))
-		;; Any dir name is ok...
 		(let-values ([(base name dir?) (split-path base)])
-		  (unless (path? name) (error "bad3"))
+		  ;; Directory must be user or "solution"
-		  ;; Base must be active or inactive
+		  (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") 
+		    (unless (path? name) (error "bad"))
-				(string=? (path->string name) "inactive"))
+		    ;; Base must be active or inactive
-		      (error "bad4"))
+		    (let-values ([(base name dir?) (split-path base)])
-		    ;; No more to path
+		      (unless (or (string=? (path->string name) "active") 
-		    (unless (equal? (build-path base 'same) (build-path handin-dir 'same))
+				  (string=? (path->string name) "inactive"))
-		      (error "bad5")))))))
+			(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 ()