Lots of changes to the handin client and server, mostly being able to deal with

group submission.

svn: r809

collects/handin-client/client.ss

@@ -68,10 +68,10 @@
 	result-msg)))
 
 
-  (define (submit-addition h username full-name id passwd)
+  (define (submit-addition h username full-name id email passwd)
     (let ([r (handin-r h)]
 	  [w (handin-w h)])
-      (fprintf w "~s create ~s ~s ~s~n" username full-name id passwd)
+      (fprintf w "~s create ~s ~s ~s ~s~n" username full-name id email passwd)
       (let ([v (read r)])
 	(unless (eq? v 'ok)
 	  (error 'handin-connect "update error: ~a" v)))

collects/handin-client/tool.ss

@@ -53,7 +53,7 @@
 
   (define handin-frame%
     (class dialog%
-      (inherit show is-shown?)
+      (inherit show is-shown? center)
       (super-new [label "Handin"])
 
       (init-field content)
@@ -138,8 +138,7 @@
       (define cancel  (new button%
 			   [label "Cancel"]
 			   [parent button-panel]
-			   [callback (lambda (b e)
+			   [callback (lambda (b e) (do-cancel-button))]))
-				       (do-cancel-button))]))
       (define (do-cancel-button)
 	(let ([go? (begin
 		     (semaphore-wait commit-lock)
@@ -245,6 +244,7 @@
 
       (init-comm)
       (send passwd focus)
+      (center)
       (show #t)))
 
   (define (manage-handin-account)
@@ -322,6 +322,7 @@
 	       (and (non-empty? new-username)
 		    (non-empty? full-name)
 		    (non-empty? student-id)
+		    (non-empty? email)
 		    (non-empty? add-passwd))))
        (define new-user-box (new vertical-panel%
 				 [parent single]
@@ -330,6 +331,7 @@
        (send new-username set-value (remembered-user))
        (define full-name  (mk-txt "Full Name:" new-user-box activate-new))
        (define student-id (mk-txt "ID:" new-user-box activate-new))
+       (define email      (mk-txt "Email:" new-user-box activate-new))
        (define add-passwd (mk-passwd "Password:" new-user-box activate-new))
        (define new-button (new button%
 			       [label "Add User"]
@@ -419,6 +421,7 @@
 	     (check-length username    50 "Username"  k)
 	     (check-length full-name  100 "Full Name" k)
 	     (check-length student-id 100 "ID"        k)
+	     (check-length email      100 "Email"     k)
 	     (check-length add-passwd  50 "Password"  k))
 	   (send tabs enable #f)
 	   (parameterize ([current-custodian comm-cust])
@@ -432,19 +435,15 @@
 		  (remember-user (send username get-value))
 		  (send status set-label "Making secure connection...")
 		  (let-values ([(h l) (connect)])
+                    (define (run proc . fields)
+                      (apply proc h (map (lambda (f) (send f get-value))
+                                         fields)))
 		    (send status set-label "Updating server...")
 		    (if new?
-			(submit-addition
+			(run submit-addition
-			 h
+                             username full-name student-id email add-passwd)
-			 (send username get-value)
+			(run submit-password-change
-			 (send full-name get-value)
+                             username old-passwd new-passwd)))
-			 (send student-id get-value)
-			 (send add-passwd get-value))
-			(submit-password-change
-			 h
-			 (send username get-value)
-			 (send old-passwd get-value)
-			 (send new-passwd get-value))))
 		  (send status set-label "Success.")
 		  (send cancel set-label "Close")))))))
 
@@ -519,7 +518,7 @@
 
           (define/override (file-menu:between-open-and-revert file-menu)
             (new menu-item%
-		 (label (format "Manage ~a..." handin-name))
+		 (label (format "Manage ~a Account..." handin-name))
 		 (parent file-menu)
 		 (callback (lambda (m e) (manage-handin-account))))
             (super file-menu:between-open-and-revert file-menu))

collects/handin-server/doc.txt

@@ -24,9 +24,7 @@ account (i.e., changing the password, or creating a new account if the
 instructor configures the server to allow new accounts).
 
 On the instructor's side, the handin server can be configured to check
-the student's submission before accepting it. Other configuration of
+the student's submission before accepting it.
-the server includes setting the list of currently active assignments
-(i.e., those for which handins are accepted).
 
 The handin process uses SSL, so it is effectively as secure as the
 server and each user's password.
@@ -197,13 +195,28 @@ sub-directories:
          oldest is in "BACKUP-0/handin.scm", next oldest is
          "BACKUP-1/handin.scm", etc.; the default is 9
 
-      'id-regexp : a regular expression used to validate a "free form"
+      'user-regexp : a regular expression that is used to validate
-         user id (possibly a student id) for a created account; the
+        usernames, young students often choose exotic usernames that
+        are impossible to remember, and forget capitalization; the
+        default is fairly strict: #rx"^[a-z][a-z0-9]+$"
+
+      'username-case-sensitive? : a boolean flag, when #f, usernames
+        are normalized to lower case for all messages; defaults to #f
+
+      'id-regexp : a regular expression that is used to validate a
+        "free form" user id (possibly a student id) for a created
+        account; the
          default is #rx"^.*$"
 
       'id-desc : a plain-words description of the acceptable format
          for a "free form" id; the default is "anything"
 
+      'email-regexp : a regular expression that is used to validate
+        emails, the #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
+        default can be changed to "" if you don't care about emails,
+        or can be further restricted, for example requiring a
+        "@cs.foo.edu" suffix
+
       'allow-new-users : a boolean indicating whether to allow
          new-user requests from a client tool; the default is #f
 
@@ -211,13 +224,22 @@ sub-directories:
          allows login as any user; the default is #f, which disables
          the password
 
+      'web-base-dir : if #f (the default), the built-in web server
+        will use the "status-web-root" in this collection for its
+        configuration; to have complete control over the built in
+        server, you can copy and edit "status-web-root" to the
+        directory you're running the handin server server from, and
+        add this configuration entry with the name of your new copy
+        (relative to the handin server directory).
+
   * "users.ss" (created if not present if a user is added) --- keeps
     the list of user accounts, along with the associated password
     (actually the MD5 hash of the password), full name, and free-form
     id (perhaps a student id at a university) of the account. The file
     format is
 
-      ((<username-sym> (<pw-md5-str> <full-name-str> <id-str>)) ...)
+      ((<username-sym> (<pw-md5-str> <id-str> <full-name-str> <email-str>))
+        ...)
 
     If the 'allow-new-users configuration allows new users, the
     "users.ss" file can be updated by the server with new users. It
@@ -226,12 +248,12 @@ sub-directories:
     The username "solution" is special. It is used by the HTTPS status
     server.
 
-  * "active/" --- sub-directory for active assignments. A list of active
+  * "active/" --- sub-directory for active assignments. A list of
-    assignments is sent to a client tool when a student clicks
+    active assignments is sent to a client tool when a student clicks
-    "Handin". The student then selects from the list. The list of
+    "Handin", based on the contents of this directory. The student
-    active assignments is built once by the server when it starts.
+    then selects from the list.  The assignments are ordered in the
-    The assignments are ordered in the student's menu using `string<?',
+    student's menu using `string<?', and the first assignment is the
-    and the first assignment is the default selection.
+    default selection.
 
     Within each directory, the student id is used for a sub-directory
     name. Within each student sub-directory are directories for handin
@@ -261,21 +283,29 @@ sub-directories:
 
   * "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
+    strings. The first is a username list and the second is the
-    submission as a byte string. (See also `unpack-submission', etc. from
+    submission as a byte string. (See also `unpack-submission',
-    "util.ss", below.) To reject the submission, the `checker'
+    etc. from "util.ss", below.) To reject the submission, the
-    function can raise an exception; the exception message will be
+    `checker' function can raise an exception; the exception message
-    relayed back to the student.
+    will be relayed back to the student.
+
+    To submit an assignment as a group, students use "user1+user2"
+    etc.  The checker function will receive a list of usernames in
+    this case -- this list is always sorted, so it can check that the
+    list of students are in a list of authorized teams.  The same
+    syntax ("user1+user2") is used for the directory for shared
+    submissions; and the usernames are always sorted so the directory
+    name is deterinistic.
 
     The `checker' function is called with the current directory as
-    "active/<assignment>/<user>/ATTEMPT", and the submission is saved
+    "active/<assignment>/<user/s>/ATTEMPT", and the submission is
-    in the file "handin". The checker function can change "handin",
+    saved in the file "handin". The checker function can change
-    and it can create additional files in this directory or the parent
+    "handin", and it can create additional files in this directory or
-    directory. (Extra files in the current directory will be preserved
+    the parent directory. (Extra files in the current directory will
-    as it is later renamed to "SUCCESS-0", etc.) To hide generated
+    be preserved as it is later renamed to "SUCCESS-0", etc.) To hide
-    files from the HTTPS status web server interface, put the files in
+    generated files from the HTTPS status web server interface, put
-    a subdirectory, which is preserved but hidden from the status
+    the files in a subdirectory, which is preserved but hidden from
-    interface.
+    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
@@ -297,13 +327,15 @@ sub-directories:
     most recent submission for <assignment> by <user> where <filename>
     was returned by the checker (or the value of the
     `default-file-name' configuration option if there's no checker).
+    If the submission is from multiple users, then "<user>" is
+    actually "<user1>+<user2>" etc.
 
   * "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s grade
     for <assignment>, to be reported by the HTTPS status web server.
 
   * "[in]active/<assignment>/solution/<file>" --- the solution to the
     assignment, made available by the status server to any user who
-    logs in. Normall, <file> is the only file in the directory
+    logs in. Normally, <file> is the only file in the directory
     "<assignment>/solution/"; if there are multiple files in the
     directory, only one named "<assignment>sol.scm" is made available
     as the solution.
@@ -360,15 +392,31 @@ The _utils.ss_ module provides utilities helpful in implementing
 
 > (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,
+  designated language, and loading teachpacks that are specified in
-  'intermediate, 'intermediate-lambda, or 'advanced. The
+  `teachpack-paths'.  The `program-port' is an input port that
-  `teachpack-paths' list contains paths to teachpacks to load in the
+  produces the content of the definitions window; use
-  evaluator. The `program-port' is an input port that produces the
+  `(open-input-string "")' for an empty definitions window.
-  content of the definitions window; use `(open-input-string "")'
+
-  for an empty definitions window.
+  The `language' can be:
+  * a symbol indicating a built-in language (currently, only
+    'mzscheme), or a teaching language -- one of 'beginner,
+    'beginner-abbr, 'intermediate, 'intermediate-lambda, or 'advanced.
+  * a list that begins with a 'lib symbol stands for the language
+    defined by this (quoted) module specification.
+  * a list that begins with a 'begin symbol means that the code will
+    not be evaluated in a module context at all, it will simply be
+    evaluated in a new namespace.
+
+  The `teachpack-paths' list specifies additional code to load, can be
+  one of:
+  * paths to teachpacks to load into the module.
+  * a list that begins with a 'begin symbol is arbitrary code that is
+    prefixed into the submitted program.
 
   The actual evaluation of expressions happens in a newly created
-  eventspace and namespace.
+  eventspace and namespace, and under the supervision of a strict
+  security guard that reading files only from PLT collections, and no
+  other operations.
 
 > (make-evaluator/submission language teachpack-paths bytes) - like
   `make-evaluator', but the definitions content is supplied as a
@@ -432,6 +480,11 @@ The _utils.ss_ module provides utilities helpful in implementing
   used when per-session memory limits are supported (i.e., under
   MrEd3m or MzScheme3m with memory accounting).
 
+> (current-value-printer proc) - a parameter that controls how values
+  are printed, a procedure that expects a Scheme value and returns a
+  string representation for it.  The default value printer uses
+  pretty-print, with DrScheme-like settings.
+
 > (reraise-exn-as-submission-problem thunk) - calls thunk in a context
   that catches exceptions and re-raises them in a form suitable as a
   submission error.

collects/handin-server/handin-server.ss

@@ -6,6 +6,7 @@
 	   (lib "file.ss")
 	   (lib "date.ss")
 	   (lib "list.ss")
+	   (lib "string.ss")
 	   "md5.ss"
 	   "lock.ss"
 	   "web-status-server.ss"
@@ -15,6 +16,10 @@
 
   (define current-session (make-parameter 0))
 
+  (define (ffprintf port str . args)
+    (apply fprintf port str args)
+    (flush-output port))
+
   (define (LOG str . args)
     ;; Assemble log into into a single string, to make
     ;;  interleaved log lines unlikely:
@@ -28,10 +33,7 @@
       (flush-output log-port)))
 
   (define (get-config which default)
-    (get-preference which 
+    (get-preference which (lambda () default) #f "config.ss"))
-		    (lambda () default)
-		    #f
-		    "config.ss"))
 
   (define PORT-NUMBER       (get-config 'port-number 7979))
   (define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
@@ -40,14 +42,14 @@
   (define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
   (define MAX-UPLOAD        (get-config 'max-upload 500000))
   (define MAX-UPLOAD-KEEP   (get-config 'max-upload-keep 9))
+  (define USER-REGEXP       (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
+  (define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
   (define ID-REGEXP         (get-config 'id-regexp #rx"^.*$"))
   (define ID-DESC           (get-config 'id-desc "anything"))
+  (define EMAIL-REGEXP      (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"))
   (define ALLOW-NEW-USERS?  (get-config 'allow-new-users #f))
   (define MASTER-PASSWD     (get-config 'master-password #f))
 
-  (define (check-id s)
-    (regexp-match ID-REGEXP s))
-
   (define orig-custodian (current-custodian))
 
   ;; On startup, check that the prefs file is not locked:
@@ -80,64 +82,75 @@
     (with-output-to-file part
       (lambda () (display s))))
 
-  (define (accept-specific-submission user assignment r r-safe w)
+  (define (accept-specific-submission users assignment r r-safe w)
-    (parameterize ([current-directory (build-path "active" assignment)])
+    ;; Note: users are always sorted
-      (unless (directory-exists? user)
+    (define dirname
-	(make-directory user))
+      (apply string-append (car users)
-      (wait-for-lock user)
+             (map (lambda (u) (string-append "+" u)) (cdr users))))
-      (parameterize ([current-directory user])
+    (define len (read r-safe))
-	(let ([len (read r-safe)])
+    (unless (and (number? len) (integer? len) (positive? len))
-	  (unless (and (number? len)
-		       (integer? len)
-		       (positive? len))
       (error 'handin "bad length: ~s" len))
     (unless (len . < . MAX-UPLOAD)
       (error 'handin
              "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
              MAX-UPLOAD len))
-	  (fprintf w "go\n")
+    (parameterize ([current-directory (build-path "active" assignment)])
-	  (flush-output w)
+      (wait-for-lock dirname)
+      (when (and (pair? users) (pair? (cdr users)))
+        ;; two or more users -- lock each one
+        (for-each wait-for-lock users))
+      (ffprintf w "go\n")
       (unless (regexp-match #rx"[$]" r-safe)
-	    (error 'handin
+        (error 'handin "did not find start-of-content marker"))
-		   "did not find start-of-content marker"))
       (let ([s (read-bytes len r)])
         (unless (and (bytes? s) (= (bytes-length s) len))
+          (error 'handin "error uploading (got ~e, expected ~s bytes)"
+                 (if (bytes? s) (bytes-length s) s) len))
+        ;; we have a submission, need to create a directory if needed, make
+        ;; sure that no users submitted work with someone else
+        (unless (directory-exists? dirname)
+          (for-each
+           (lambda (dir)
+             (for-each
+              (lambda (d)
+                (when (member d users)
                   (error 'handin
-		     "error uploading (got ~e, expected ~s bytes)"
+                         "bad submission: ~a has an existing submission (~a)"
-		     (if (bytes? s) (bytes-length s) s)
+                         d dir)))
-		     len))
+              (regexp-split #rx"[+]" (path->string dir))))
-	    ;; Shift successful-attempt directories so that there's
+           (directory-list))
-	    ;;  no SUCCESS-0:
+          (make-directory dirname))
-	    (make-success-dir-available 0)
+        (parameterize ([current-directory dirname])
           ;; 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)
+          (LOG "checking ~a for ~a" assignment users)
           (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)
+                       ((dynamic-require (path->complete-path checker) 'checker)
-			      user s)))
+                        users s))
                      DEFAULT-FILE-NAME))])
-	      (fprintf w "confirm\n")
+            (ffprintf 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)
+                  (LOG "saving ~a for ~a" assignment users)
                   (parameterize ([current-directory ATTEMPT-DIR])
                     (rename-file-or-directory "handin" (if (pair? part) (car part) part)))
+                  ;; Shift successful-attempt directories so that there's
+                  ;;  no SUCCESS-0:
+                  (make-success-dir-available 0)
                   (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)))))))))
+                (error 'handin "upload not confirmed: ~s" v))))))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -153,18 +166,23 @@
 			(lambda (f)
 			  (error 
 			   'handin 
-			   "user database busy; please try again, and alert the adminstrator is problems persist"))
+			   "user database busy; please try again, and alert the adminstrator if problems persist"))
 			"users.ss"))
      orig-custodian))
 
   (define (add-new-user username r-safe w)
+    (thread (lambda () (sleep 5) (close-input-port r-safe)))
     (let ([full-name (read r-safe)]
 	  [id        (read r-safe)]
+	  [email     (read r-safe)]
 	  [passwd    (read r-safe)])
       (unless (and (string? full-name)
 		   (string? id)
+		   (string? email)
 		   (string? passwd))
 	(error 'handin "bad user-addition request"))
+      (unless (regexp-match USER-REGEXP username)
+        (error 'handin "bad user name: \"~a\"" username))
       ;; Since we're going to use the username in paths:
       (when (regexp-match #rx"[/\\:]" username)
 	(error 'handin "username must not contain a slash, backslash, or colon"))
@@ -173,10 +191,13 @@
 	(error 'handin "username must not be a Windows special file name"))
       (when (string=? "solution" username)
 	(error 'handin "the username \"solution\" is reserved"))
-      (unless (check-id id)
+      (unless (regexp-match ID-REGEXP id)
 	(error 'handin "id has wrong format: ~a; need ~a for id" id ID-DESC))
+      (unless (regexp-match EMAIL-REGEXP email)
+        (error 'handin "email has wrong format: ~a" email))
+      (LOG "create user: ~a" username)
       (put-user (string->symbol username)
-		(list (md5 passwd) id full-name))
+		(list (md5 passwd) id full-name email))
       (fprintf w "ok~n")))
 
   (define (change-user-passwd username r-safe w old-user-data)
@@ -192,43 +213,57 @@
 
   (define (accept-submission-or-update active-assignments r r-safe w)
     (fprintf w "~s~n" active-assignments)
-    ;; Get username and password:
+    ;; Get usernames and password:
-    (let ([username (read r-safe)]
+    (let* ([user-string
+            (let ([s (read r-safe)])
+              (and (string? s)
+                   (if USERNAME-CASE-SENSITIVE?
+                     s
+                     (let ([s (string-copy s)]) (string-lowercase! s) s))))]
+           [usernames
+            ;; User name lists must always be sorted
+            (if user-string
+              (quicksort (regexp-split #rx" *[+] *" user-string) string<?)
+              '())]
+           [user-datas (map (lambda (u)
+                              (get-preference (string->symbol u)
+                                              (lambda () #f) #f "users.ss"))
+                            usernames)]
            [passwd (read r-safe)])
-      (let ([user-data
-	     (and (string? username)
-		  (get-preference (string->symbol username)
-				  (lambda () #f)
-				  #f
-				  "users.ss"))])
       (cond
        [(eq? passwd 'create)
-	  (when user-data
-	    (error 'handin "username already exists: ~a" username))
         (unless ALLOW-NEW-USERS?
-	    (error 'handin "new users not allowed: ~a" username))
+          (error 'handin "new users not allowed: ~a" user-string))
-	  (LOG "create user: ~a" username)
+        (unless (= 1 (length usernames))
-	  (add-new-user username r-safe w)]
+          (error 'handin "username must not contain a \"+\": ~a" user-string))
-	 [(and user-data
+        ;; we now know that there is a single username, and (car usernames) is
+        ;; the same at user-string
+        (when (car user-datas)
+          (error 'handin "username already exists: `~a'" user-string))
+        (add-new-user user-string r-safe w)]
+       [(and (pair? user-datas)
+             (not (memq #f user-datas))
              (string? passwd)
              (let ([pw (md5 passwd)])
-		 (or (equal? pw (car user-data))
+               (ormap (lambda (p) (equal? p pw))
-		     (equal? pw MASTER-PASSWD))))
+                      (cons MASTER-PASSWD (map car user-datas)))))
-	  (LOG "login: ~a" username)
+        (LOG "login: ~a" usernames)
         (let ([assignment (read r-safe)])
-	    (LOG "assignment for ~a: ~a" username assignment)
+          (LOG "assignment for ~a: ~a" usernames assignment)
           (if (eq? assignment 'change)
-		(change-user-passwd username r-safe w user-data)
+            (if (= 1 (length usernames))
+              (change-user-passwd (car usernames) r-safe w (car user-datas))
+              (error 'handin "cannot change a password on a joint login"))
             (if (member assignment active-assignments)
               (begin
                 (fprintf w "ok\n")
-		      (accept-specific-submission username assignment r r-safe w))
+                (accept-specific-submission usernames assignment r r-safe w))
               (error 'handin "not an active assignment: ~a" assignment))))]
        [else
-	  (LOG "failed login: ~a" username)
+        (LOG "failed login: ~a" user-string)
-	  (error 'handin "bad username or password for ~a" username)]))))
+        (error 'handin "bad username or password for ~a" user-string)])))
 
-  (define assignment-list
+  (define (assignment-list)
     (quicksort (map path->string (directory-list "active")) string<?))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -295,7 +330,7 @@
 
   (LOG "server started ------------------------------")
 
-  (define stop-status (serve-status HTTPS-PORT-NUMBER))
+  (define stop-status (serve-status HTTPS-PORT-NUMBER get-config))
 
   (define session-count 0)
 
@@ -316,8 +351,7 @@
 	  w
 	  (lambda (kill-watcher)
 	    (let ([r-safe (make-limited-input-port r 1024)])
-	      (fprintf w "handin\n")
+	      (ffprintf w "handin\n")
-	      (flush-output w)
 	      ;; Check protocol:
 	      (with-handlers ([exn:fail?
 			       (lambda (exn)
@@ -326,17 +360,14 @@
 						(format "~e" exn))])
 				   (kill-watcher)
 				   (LOG "ERROR: ~a" msg)
-				   (fprintf w "~s\n" msg)
+				   (ffprintf w "~s\n" msg)
-				   (flush-output w)
 				   ;; see note on close-output-port below
 				   (close-output-port w)))])
 		(let ([protocol (read r-safe)])
 		  (if (eq? protocol 'original)
-		      (begin
+		      (ffprintf w "original\n")
-			(fprintf w "original\n")
-			(flush-output w))
 		      (error 'handin "unknown protocol: ~s" protocol)))
-		(accept-submission-or-update assignment-list r r-safe w)
+		(accept-submission-or-update (assignment-list) r r-safe w)
 		(LOG "normal exit")
 		(kill-watcher)
 		;; This close-output-port should not be necessary, and it's

collects/handin-server/lock.ss

@@ -5,49 +5,55 @@
   (provide wait-for-lock)
 
   ;; wait-for-lock : string -> void
-  ;;  Gets a lock on `user' for the calling thread; the lock
+  ;;  Gets a lock on `user' for the calling thread; the lock lasts until the
-  ;;  lasts until the calling thread terminates.
+  ;;  calling thread terminates.  If the lock was actually acquired, then on
-  (define (wait-for-lock user)
+  ;;  release the cleanup-thunk will be executed (unless it is #f), even if it
+  ;;  was released when the acquiring thread crashed.
+  ;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception,
+  ;; since this will kill the lock thread which will lock down everything
+  (define (wait-for-lock user . cleanup-thunk)
     (let ([s (make-semaphore)])
-      (channel-put req-ch (make-req 
+      (channel-put req-ch
-			   (thread-dead-evt (current-thread))
+                   (make-req (thread-dead-evt (current-thread)) user s
-			   user
+                             (and (pair? cleanup-thunk) (car cleanup-thunk))))
-			   s))
       (semaphore-wait s)))
 
   (define req-ch (make-channel))
 
-  (define-struct req (thread-dead-evt
+  (define-struct req (thread-dead-evt user sema cleanup-thunk))
-		      user
-		      sema))
 
-  (thread (lambda ()
+  (thread
+   (lambda ()
      (let loop ([locks null]
                 [reqs null])
        (let-values ([(locks reqs)
                      ;; Try to satisfy lock requests:
-			    (let loop ([reqs (reverse reqs)][locks locks][new-reqs null])
+                     (let loop ([reqs (reverse reqs)]
-			      (cond
+                                [locks locks]
-			       [(null? reqs) (values locks new-reqs)]
+                                [new-reqs null])
-			       [(assoc (req-user (car reqs)) locks)
+                       (if (null? reqs)
+                         (values locks new-reqs)
+                         (let ([req (car reqs)]
+                               [rest (cdr reqs)])
+                           (if (assoc (req-user req) locks)
                              ;; Lock not available:
-				(loop (cdr reqs) locks (cons (car reqs) new-reqs))]
+                             (loop rest locks (cons req new-reqs))
-			       [else
                              ;; Lock is available, so take it:
-				(let ([req (car reqs)])
+                             (begin (semaphore-post (req-sema req))
-				  (semaphore-post (req-sema req))
+                                    (loop (cdr reqs)
-				  (loop (cdr reqs) (cons (cons (req-user req) req) locks) new-reqs))]))])
+                                          (cons (cons (req-user req) req) locks)
+                                          new-reqs))))))])
          (sync
-		 (handle-evt
+          (handle-evt req-ch (lambda (req) (loop locks (cons req reqs))))
-		  req-ch
-		  (lambda (req)
-		    (loop locks (cons req reqs))))
           ;; Release a lock whose thread is gone:
           (apply choice-evt
                  (map (lambda (name+req)
                         (handle-evt
                          (req-thread-dead-evt (cdr name+req))
                          (lambda (v)
+                           ;; releasing a lock => run cleanup
+                           (cond [(req-cleanup-thunk (cdr name+req))
+                                  => (lambda (t) (t))])
                            (loop (remq name+req locks) reqs))))
                       locks))
           ;; Throw away a request whose thread is gone:
@@ -55,6 +61,5 @@
                  (map (lambda (req)
                         (handle-evt
                          (req-thread-dead-evt req)
-				(lambda (v)
+                         (lambda (v) (loop locks (remq req reqs)))))
-				  (loop locks (remq req reqs)))))
                       reqs))))))))

collects/handin-server/status-web-root/htdocs/index.html

@@ -2,5 +2,7 @@
 <head><title>Handin Status Web Server</title></head>
 <body>
 The handin status server is running.
+<br>
+You can <a href="/servlets/status.ss">check your submissions</a> on this server.
 </body>
 </html>

collects/handin-server/utils.ss

@@ -5,7 +5,8 @@
 	   "run-status.ss"
 	   (prefix pc: (lib "pconvert.ss"))
 	   (lib "pretty.ss")
-	   (lib "list.ss"))
+	   (lib "list.ss")
+	   (lib "string.ss"))
 
   (provide unpack-submission
 
@@ -21,6 +22,7 @@
 	   call-with-evaluator/submission
 	   reraise-exn-as-submission-problem
 	   current-run-status
+           current-value-printer
 
 	   check-proc
 	   check-defined
@@ -130,6 +132,31 @@
 
       (super-new)))
 
+  ;; Protection ---------------------------------------
+
+  (define ok-path-re
+    (regexp
+     (string-append
+      "^(?:"
+      (apply string-append
+             (cdr (apply append (map (lambda (p) (list "|" (regexp-quote p)))
+                                     (current-library-collection-paths)))))
+      ")(?:/|$)")))
+
+  (define tight-security
+    (make-security-guard
+     (current-security-guard)
+     (lambda (what path modes)
+       (when (or (memq 'write modes)
+                 (memq 'execute modes)
+                 (memq 'delete modes)
+                 (not (regexp-match ok-path-re (path->string path))))
+         (error what "file access denied (~a)" path)))
+     (lambda (what host port mode) (error what "network access denied"))))
+
+  (define (safe-eval expr)
+    (parameterize ([current-security-guard tight-security])
+      (eval expr)))
 
   ;; Execution ----------------------------------------
 
@@ -149,27 +176,55 @@
 	     (lambda ()
 	       ;; First read program and evaluate it as a module:
 	       (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
-		 (let ([prog-body
+		 (let* ([body
                          (parameterize ([read-case-sensitive #t]
                                         [read-decimal-as-inexact #f])
                            (let loop ([l null])
                              (let ([expr (read-syntax 'program program-port)])
                                (if (eof-object? expr)
                                  (reverse l)
-				  (loop (cons expr l))))))])
+                                 (loop (cons expr l))))))]
-		   (eval `(module m (lib ,(case language
+                        [body (append (if (and (pair? teachpacks)
+                                               (eq? 'begin (car teachpacks)))
+                                        (cdr teachpacks)
+                                        (map (lambda (tp)
+                                               `(,#'require
+                                                 ,(if (pair? tp)
+                                                    tp `(file ,tp))))
+                                             teachpacks))
+                                      body)]
+                        [body
+                         (cond
+                          [(and (symbol? language)
+                                (memq language '(beginner
+                                                 beginner-abbr
+                                                 intermediate
+                                                 intermediate-lambda
+                                                 advanced)))
+                           `(module m
+                                (lib ,(case language
                                         [(beginner) "htdp-beginner.ss"]
                                         [(beginner-abbr) "htdp-beginner-abbr.ss"]
                                         [(intermediate) "htdp-intermediate.ss"]
                                         [(intermediate-lambda) "htdp-intermediate-lambda.ss"]
                                         [(advanced) "htdp-advanced.ss"])
                                      "lang")
-			    ,@(map (lambda (tp)
+                              ,@body)]
-				     `(,#'require (file ,tp)))
+                          [(or (and (pair? language) (eq? 'lib (car language)))
-				   teachpacks)
+                               (symbol? language))
-			    ,@prog-body))
+                           `(module m ,language ,@body)]
-		   (eval `(require m))
+                          [(and (pair? language)
-		   (current-namespace (module->namespace 'm)))
+                                (eq? 'begin (car language)))
+                           `(begin ,language ,@body)]
+                          [else (error 'make-evaluator
+                                       "Bad language specification: ~e"
+                                       language)])])
+                   (safe-eval body)
+                   (when (and (pair? body) (eq? 'module (car body))
+                              (pair? (cdr body)) (symbol? (cadr body)))
+                     (let ([mod (cadr body)])
+                       (safe-eval `(require ,mod))
+                       (current-namespace (module->namespace mod)))))
 		 (channel-put result-ch 'ok))
 	       ;; Now wait for interaction expressions:
 	       (let loop ()
@@ -177,7 +232,7 @@
 		   (unless (eof-object? expr)
 		     (with-handlers ([void (lambda (exn)
 					     (channel-put result-ch (cons 'exn exn)))])
-		       (channel-put result-ch (cons 'val (eval expr))))
+		       (channel-put result-ch (cons 'val (safe-eval expr))))
 		     (loop))))
 	       (let loop ()
 		 (channel-put result-ch '(exn . no-more-to-evaluate))
@@ -304,7 +359,7 @@
 		   [pc:constructor-style-printing #t])
       (pc:print-convert v)))
 
-  (define (value-printer v)
+  (define (default-value-printer v)
     (parameterize ([pretty-print-show-inexactness #t]
 		   [pretty-print-.-symbol-without-bars #t]
 		   [pretty-print-exact-as-decimal #t]
@@ -313,10 +368,11 @@
       (let ([p (open-output-string)])
 	(pretty-print (value-converter v) p)
 	(regexp-replace #rx"\n$" (get-output-string p) ""))))
+  (define current-value-printer (make-parameter default-value-printer))
 
   (define (call-with-evaluator lang teachpacks program-port go)
     (parameterize ([error-value->string-handler (lambda (v s)
-						  (value-printer v))]
+						  ((current-value-printer) v))]
 		   [list-abbreviation-enabled (not (or (eq? lang 'beginner)
 						       (eq? lang 'beginner-abbr)))])
       (reraise-exn-as-submission-problem
@@ -330,4 +386,3 @@
       (call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
 
   )
-

collects/handin-server/web-status-server.ss

@@ -7,11 +7,20 @@
 	   (lib "ssl-tcp-unit.ss" "net")
 	   (lib "tcp-sig.ss" "net")
 	   (lib "tcp-unit.ss" "net")
-	   (lib "file.ss"))
+	   (lib "file.ss")
+	   (lib "etc.ss"))
 
   (provide serve-status)
 
-  (define (serve-status port-no)
+  (define (serve-status port-no get-config)
+
+    (define WEB-BASE-DIR (get-config 'web-base-dir #f))
+
+    (define web-dir
+      (path->string
+       (if WEB-BASE-DIR
+         (build-path (current-directory) WEB-BASE-DIR)
+         (build-path (this-expression-source-directory) "status-web-root"))))
 
     (define config
       `((port ,port-no)
@@ -37,10 +46,10 @@
 	    (file-base-connection-timeout 30))
 	   (paths
 	    (configuration-root "conf")
-	    (host-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
+	    (host-root ,web-dir)
 	    (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss")))
 	    (file-root "htdocs")
-	    (servlet-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
+	    (servlet-root ,web-dir)
 	    (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
 	(virtual-host-table)))