From 5937a488ea079791b40ea9623ec9ba75b0a0ac52 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 19 Feb 2008 08:27:09 +0000
Subject: [PATCH] * removed useless name from info * docs build into
 user-specific directory so they're not a problem   with not including this in
 the distribution. * misc doc improvements * renamed handin-server.ss to
 main.ss * basic operation is fine with v4

svn: r8716
---
 collects/handin-server/checker.ss           |    4 +-
 collects/handin-server/doc.txt              | 1136 -------------------
 collects/handin-server/handin-server.ss     |  693 -----------
 collects/handin-server/info.ss              |    4 +-
 collects/handin-server/main.ss              |  691 +++++++++++
 collects/handin-server/web-status-server.ss |  151 ++-
 6 files changed, 768 insertions(+), 1911 deletions(-)
 delete mode 100644 collects/handin-server/doc.txt
 delete mode 100644 collects/handin-server/handin-server.ss
 create mode 100644 collects/handin-server/main.ss

diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss
index f8eac32bac..ed2abeec08 100644
--- a/collects/handin-server/checker.ss
+++ b/collects/handin-server/checker.ss
@@ -1,4 +1,4 @@
-(module checker mzscheme
+#lang mzscheme
 
 (require "utils.ss" (lib "file.ss") (lib "list.ss") (lib "class.ss")
          (lib "mred.ss" "mred"))
@@ -730,5 +730,3 @@
          ((if (pair? proc) (car proc) handler) loc)))]
     [(null? uncovered) #f]
     [else (error* "bad checker: no coverage information for !all-covered")]))
-
-)
diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt
deleted file mode 100644
index 33c2737ce7..0000000000
--- a/collects/handin-server/doc.txt
+++ /dev/null
@@ -1,1136 +0,0 @@
-
-_Handin Server and Client_
-
-The "handin-server" directory contains a server to be run by a course
-instructor for accepting homework assignments and reporting on
-submitted assignments.
-
-The "handin-client" directory contains a client to be customized then
-re-distributed to students in the course.  The customized client will
-embed a particular hostname and port where the server is running, as
-well as a server certificate.
-
-With a customized client, students simply install a ".plt" file --- so
-there's no futzing with configuration dialogs and certificates.  A
-student can install any number of clients at once (assuming that the
-clients are properly customized, as described below).
-
-The result, on the student's side, is a "Handin" button in DrScheme's
-toolbar.  Clicking the "Handin" button allows the student to type a
-password and upload the current content of the definitions and
-interactions window to the course instructor's server.  The "File"
-menu is also extended with a "Manage..." menu item for managing a
-handin account (i.e., changing the password and other information, or
-creating a new account if the instructor configures the server to
-allow new accounts).  Students can submit joint work by submitting
-with a concatenation of usernames separated by a "+".
-
-On the instructor's side, the handin server can be configured to check
-the student's submission before accepting it.
-
-The handin process uses SSL, so it is effectively as secure as the
-server and each user's password.
-
-
-Quick Start for a Test Drive:
-=============================
-
- 1.  Create a new directory.
-
- 2.  Copy "server-cert.pem" from the "handin-client" collection
-     to the new directory.
-       NOTE: For real use, you need a new certificate.
-       NOTE: See also "Where is the collection?", below.
-
- 3.  Copy "private-key.pem" from the "handin-server" collection
-     to the new directory.
-       NOTE: For real use, you need a new key.
-
- 4.  Create a file "users.ss" with the following content:
-       ((tester ("8fe4c11451281c094a6578e6ddbf5eed" 
-                 "Tester" "1" "test@cs")))
-
- 5.  Make a "test" subdirectory in your new directory.
-
- 6.  Create a file "config.ss" with the following content:
-       ((active-dirs ("test")))
-
- 7.  In your new directory, run
-        mred -mvqM handin-server
-
- 8.  In the "handin-client" collection, edit "info.ss" and
-     uncomment the lines that define `server:port', `tools', 
-     `tool-names', and `tool-icons'.
-
- 9. Run `setup-plt -l handin-client'
-      NOTE: Under Windows, the executable is "Setup PLT" 
-            instead of setup-plt.
-      NOTE: The command line arguments are optional.
-
- 10. Start DrScheme, click "Handin" to run the client, submit with
-     username "tester" and password "pw".
-
-     The submitted file will be .../test/tester/handin.scm.
-
- 11. Check the status of your submission by pointing a web browser at
-        https://localhost:7980/servlets/status.ss
-     Note the "s" in "https". Use the "tester" username and "pw"
-     password, as before.
-
-  -------------------------------------------------------------------
- | "Where is the collection?"                                        |
- |- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -|
- | If you obtained the server and client by installing a .plt file,  |
- | then the "handin-server" and "handin-client" directories          |
- | might be in your PLT addon space.  Start MzScheme, and enter      |
- |         (collection-path "handin-server")                         |
- |         (collection-path "handin-client")                         |
- | to find out where these collections are.                          |
-  -------------------------------------------------------------------
-
-
-Client Customization:
-=====================
-
-  1. Rename (or make a copy of) the "handin-client" collection
-     directory.  The new name should describe your class uniquely.
-     For example, "uu-cpsc2010" is a good name for CPSC 2010 at the
-     University of Utah.
-
-  2. Edit the first three definitions of "info.ss" in your renamed
-     client collection:
-
-       * For `name', choose a name for the handin tool as it will
-         appear in DrScheme's interface (e.g., the "XXX" for the
-         "Manage XXX Handin Account..."  menu item).  Again, make the
-         name specific to the course, in case a student installs
-         multiple handin tools.  Do not use "Handin" as the last part
-         of the name, since "Handin" is always added for button and
-         menu names.
-
-       * Uncomment the definitions of 'tools', 'tool-names', and
-         'tool-icons'.
-
-       * For `server:port', uncomment the line, and use the hostname
-         and port where the server will be running to accept handin
-         submissions.
-
-      Optionally uncomment and edit the next two definitions,
-      `web-menu-name' and `web-address', to add an item to the "Help"
-      menu that opens a (course-specific) web page.
-
-   3. Replace "icon.png" in your renamed directory with a new 32x32
-      icon.  This icon is displayed on startup with DrScheme's splash
-      screen, and it is included at half size on the "Handin" button.
-      Again, choose a distinct icon for the benefit of students who
-      install multiple handin tools.  A school logo is typically
-      useful, as it provides a recognizably local visual cue.
-
-   4. Replace "server-cert.pem" in your renamed directory with a
-      server certificate.  The file "server-cert.pem" in
-      "handin-client" collection is ok for testing, but the point of
-      this certificate is to make handins secure, so you should
-      generate a new (self-certifying) certificate and keep its key
-      private.  (See server setup, below.)
-
-   5. Run
-           mzc --collection-plt <name>.plt <name>
-      where <name> is the name that you chose for your directory
-      (i.e., whatever you changed "handin-client" to).
-
-   6. Distribute <name>.plt to students for installation into their
-      copies of DrScheme.  The students need not have access to the
-      DrScheme installation directory; the tool will be installed on
-      the filesystem in the student's personal space.  If you want to
-      install it once on a shared installation, use setup-plt with the
-      --all-users flag.
-
-
-Server Setup:
-=============
-
-You must prepare a special directory to host the handin server.  To
-run the server, you should either be in this directory, or you should
-set the "PLT_HANDINSERVER_DIR" environment variable.
-
-This directory contains the following files and sub-directories:
-
-  * "server-cert.pem" --- the server's certificate.  To create a
-    certificate and key with openssl:
-
-      openssl req -new -nodes -x509 -days 365 -out server-cert.pem
-                  -keyout private-key.pem
-
-  * "private-key.pem" --- the private key to go with
-    "server-cert.pem".  Whereas "server-cert.pem" gets distributed to
-    students with the handin client, "private-key.pem" is kept
-    private.
-
-  * "config.ss" --- configuration options.  The file format is
-
-         ((<key> <val>) ...)
-
-    The following keys can be used (without the preceding quote):
-
-      'active-dirs : a list of directories that are active
-         submissions, relative to the current directory or absolute;
-         the last path element for each of these (and 'inactive-dirs
-         below) should be unique, and is used to identify the
-         submission (for example, in the client's submission dialog
-         and in the status servlet)
-
-      'inactive-dirs : a list of inactive submission directories (see
-         above for details)
-
-      'port-number : the port for the main handin server; the default
-         is 7979
-
-      'https-port-number : the port number for the handin-status HTTPS
-         server; the default is #f which indicates that no HTTPS
-         server is started
-
-      'session-timeout : number of seconds before the session
-         times-out -- the client is given this many seconds for the
-         login stage and then starts again so the same number of
-         seconds is given for the submit-validation process; the
-         default is 300
-
-      'session-memory-limit : maximum size in bytes of memory allowed
-         for per-session computation, if per-session limits are
-         supported (i.e., when using MrEd3m and MzScheme3m with memory
-         accounting); the default is 40000000
-
-      'default-file-name : the default filename that will be saved
-        with the submission contents.  The default is "handin.scm".
-
-      'max-upload : maximum size in bytes of an acceptable submission;
-         the default is 500000
-
-      'max-upload-keep : maximum index of submissions to keep; the
-         most recent submission is "handin.scm" (by default), the next
-         oldest is in "BACKUP-0/handin.scm", next oldest is
-         "BACKUP-1/handin.scm", etc.; the default is 9
-
-      'user-regexp : a regular expression that is used to validate
-         usernames; alternatively, this can be `#f' meaning no
-         restriction, or a list of permitted strings.  Young students
-         often choose exotic usernames that are impossible to
-         remember, and forget capitalization, so the default is fairly
-         strict: #rx"^[a-z][a-z0-9]+$"; a "+" is always disallowed in
-         a username, since it is used in a submission username to
-         specify joint work
-
-      'user-desc : a plain-words description of the acceptable
-         username format (according to user-regexp above); `#f' stands
-         for no description; the default is "alphanumeric string"
-         which matches the default user-regexp
-
-      'username-case-sensitive : a boolean; when `#f', usernames are
-         case-folded for all purposes; defaults to `#f' (note that you
-         should not set this to `#t' on Windows or when using other
-         case-insensitive filesystems, since usernames are used as
-         directory names)
-
-      'allow-new-users : a boolean indicating whether to allow
-         new-user requests from a client tool; the default is `#f'
-
-      'allow-change-info : a boolean indicating whether to allow
-         changing user information from a client tool (changing
-         passwords is always possible); the default is `#f'
-
-      'master-password : a string for an MD5 hash for a password that
-         allows login as any user; the default is `#f', which disables
-         the password
-
-      'log-output : a boolean that controls whether the handin server
-         log is written on the standard output; defaults to `#t'
-
-      'log-file : a path (relative to handin server directory or
-         absolute) that specifies a filename for the handin server log
-         (possibly combined with the 'log-output option), or `#f' for
-         no log file; defaults to "log"
-
-      '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", and add this
-         configuration entry with the name of your new copy (relative
-         to the handin server directory, or absolute)
-
-      'web-log-file : a path (relative to handin server directory or
-         absolute) that specifies a filename for logging the internal
-         HTTPS status web server; or `#f' (the default) to disable
-         this log
-
-      'extra-fields : a list that describes extra string fields of
-         information for student records; each element in this list is
-         a list of three values -- the name of the field, the regexp
-         (or `#f', or a list of permitted string values), and a string
-         describing of acceptable strings.  The default is
-
-           '(("Full Name" #f #f)
-             ("ID#" #f #f)
-             ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
-              "a valid email address"))
-
-         You can set this to a list of fields that you are interested
-         in keeping, for example:
-
-           '(("Full Name"
-              #rx"^[A-Z][a-zA-Z]+(?: [A-Z][a-zA-Z]+)+$"
-              "full name, no punctuations, properly capitalized")
-             ("Utah ID Number"
-              #rx"^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$"
-              "Utah ID Number with exactly nine digits")
-             ("Email"
-              #rx"^[^@<>\"`',]+@cs\\.utah\\.edu$"
-              "A Utah CS email address"))
-
-         The order of these fields will be used both on the client GUI
-         side and in the "users.ss" file (see below).
-
-         The second item in a field description can also be the symbol
-         '-, which marks this field as one that is hidden from the
-         user interface: students will not see it and will not be able
-         to provide or modify it; when a new student creates an
-         account, such fields will be left empty.  This is useful for
-         adding information that you have on students from another
-         source, for example, adding information from a course roster.
-         You should manually edit the "users.ss" file and fill in such
-         information.  (The third element for such descriptors is
-         ignored.)
-
-      'hook-file : a path (relative to handin server directory or
-         absolute) that specifies a filename that contains a `hook'
-         module.  This is useful as a general device for customizing
-         the server through Scheme code.  The file is expected to
-         contain a module that provides a `hook' function, which
-         should be receiving three arguments:
-         - a symbol that indicates the operation that is now taking
-           place;
-         - a datum that specifies the connection context (a number for
-           handin connections, a `wN' symbol for servlet connections,
-           and #f for other server operations);
-         - an alist of information relevant to this operation.
-         Currently, the hook is used in several places after an
-         operation has completed.  The first argument will be one of
-         these symbols: 'server-start, 'server-connect, 'user-create,
-         'user-change, 'login, 'submission-received,
-         'submission-committed, 'submission-retrieved, 'status-login,
-         'status-file-get.  For example, here is a simple hook module
-         that sends notification messages when users are created or
-         their information has changed:
-
-           (module hook mzscheme
-             (provide hook)
-             (require (lib "sendmail.ss" "net"))
-             (define (hook what session alist)
-               (when (memq what '(user-create user-change))
-                 (send-mail-message
-                  "course-staff@university.edu"
-                  (format "[server] ~a (~a)" what session)
-                  '("course-staff@university.edu") '() '()
-                  (map (lambda (key+val)
-                         (apply format "~a: ~s" key+val))
-                       alist)))))
-
-    Changes to "config.ss" are detected, the file will be re-read, and
-    options are reloaded.  A few options are fixed at startup time:
-    port numbers, log file specs, and the `web-base-dir' are as
-    configured at startup.  All other options will change the behavior
-    of the running server (but things like `username-case-sensitive?'
-    it would be unwise to do so).  (For safety, options are not
-    reloaded until the file parses correctly, but make sure that you
-    don't save a copy that has inconsistent options: it is best to
-    create a new configuration file and move it over the old one, or
-    use an editor that does so and not save until the new contents is
-    ready.)  This is most useful for closing & openning submission
-    directories.
-
-  * "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), and extra string fields
-    as specified by the 'extra-fields configuration entry (in the same
-    order).  The file format is
-
-      ((<username-sym> (<pw-md5-str> <extra-field> ...))
-        ...)
-
-    For example, the default 'extra-field setting will make this:
-
-      ((<username-sym> (<pw-md5-str> <full-name> <id> <email>))
-        ...)
-
-    Username that begin with "solution" are special.  They are used by
-    the HTTPS status server.  Independent of the 'user-regexp and
-    'username-case-sensitive? configuration items, usernames are not
-    allowed to contain characters that are illegal in Windows
-    pathnames, they cannot end or begin in spaces or periods.
-
-    If the 'allow-new-users configuration allows new users, the
-    "users.ss" file can be updated by the server with new users.  It
-    can always be updated by the server to change passwords.
-
-    If you have access to a standard Unix password file (from
-    "/etc/passwd" or "/etc/shadow"), then you can construct a
-    "users.ss" file that will allow users to use their normal
-    passwords.  To achieve this, use a list with 'unix as the first
-    element and the system's encrypted password string as the second
-    element.  Such passwords can be used, but when users change them,
-    a plain md5 hash will be used.
-
-    You can combine this with other fields from the password file to
-    create your "users.ss", but make sure you have information that
-    matches your 'extra-fields specification.  For example, given this
-    system file:
-
-      foo:wRzN1u5q2SqRD:1203:1203:L.E. Foo:/home/foo:/bin/tcsh
-      bar:$1$dKlU0OkJ$t63TzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash
-
-    you can create this "users.ss" file:
-
-      ((foo ((unix "wRzN1u5q2SqRD") "L.E. Foo" "?"))
-       (bar ((unix "$1$dKlU0OkJ$t63TzKz") "Bar Z. Lie" "?")))
-
-    which can be combined with this setting for 'extra-fields in your
-    "config.ss":
-
-      ...
-      (extra-fields (("Full Name" #f #f)
-                     ("TA" '("Alice" "Bob") "Your TA")))
-      ...
-
-    and you can tell your students to use their department username
-    and password, and use the "Manage ..." dialog to properly set
-    their TA name.
-
-    Finally, a password value can be a list that begins with a
-    'plaintext symbol, which will be used without encryption.  This
-    may be useful for manually resetting a forgotten passwords.
-
-  * "log" (or any other name that the 'log-file configuration option
-    specifies (if any), created if not present, appended otherwise)
-    --- records connections and actions, where each entry is of the
-    form
-        (id time-str msg-str)
-        [<id>|<time>] <msg>
-    where `<id>' is an integer representing the connection (numbered
-    consecutively from 1 when the server starts), "-" for a message
-    without a connection, and "wN" for a message from the status
-    servlet.
-
-  * Active and inactive assignment directories (which you can put in a
-    nested directory for convenience, or specify a different absolute
-    directory), as specified by the configuration file using the
-    `active-dirs' and `inactive-dirs'.  A list of active assignment
-    directories (the last path element in each specified path is used
-    as a label) is sent to the client tool when a student clicks
-    "Handin".  The assignment labels are ordered in the student's menu
-    using `string<?', and the first assignment is the default
-    selection.
-
-    Within each assignment directory, the student id is used for a
-    sub-directory name.  Within each student sub-directory are
-    directories for handin attempts and successes.  If a directory
-    "ATTEMPT" exists, it contains the most recent (unsuccessful or
-    currently-in-submission) handin attempt.  Directories "SUCCESS-n"
-    (where n counts from 0) contain successful handins; the lowest
-    numbered such directory represents the latest handin.
-
-    A cleanup process in the server copies successful submissions to
-    the student directory -- one level up from the corresponding
-    "SUCCESS-n" directory.  This is done only for files and
-    directories that are newer in "SUCCESS-n" than in the submission
-    root, other files and directories are left intact.  If external
-    tools add new content to the student directory (eg, a "grade"
-    file, as described below) it will stay there.  If the machine
-    crashes or the server is stopped, the cleanup process might not
-    finish.  When the server is started, it automatically runs the
-    cleanup process for each student directory.
-
-    Within a student directory, a "handin.scm" file (or some other
-    name if the `default-file-name' option is set) contains the actual
-    submission.  A `checker' procedure can change this default file
-    name, and it can create additional files in an "ATTEMPT" directory
-    (to be copied by the cleanup process); see below for more details
-    on "checker.ss".
-
-    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
-    definitions part.  To get both the definitions and interactions
-    parts, the file can be parsed with `unpack-submission' from
-    "utils.ss" (see below).
-
-    To submit an assignment as a group, students use a concatenation
-    of usernames separated by "+" and any number of spaces (e.g.,
-    "user1+user2").  The same syntax ("user1+user2") is used for the
-    directory for shared submissions, where the usernames are always
-    sorted so that directory names are deterministic.  Multiple
-    submissions for a particular user in different groups will be
-    rejected.
-
-    Inactive assignment directories are used by the the HTTPS status
-    web server.
-
-  * "<active-assignment>/checker.ss" (optional) --- a module that
-    exports a `checker' function.  This function receives two
-    arguments: a username list and a 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 module is loaded when the current directory is the
-    main server directory, so it can read files from there (but note
-    that to read values from "config.ss" it is better to use
-    `get-conf').  Also, the module will be reloaded if the checker
-    file is modified -- no need to restart the server, but make sure
-    that you do not save a broken checker (ie, do not save in
-    mid-edit).
-
-    The first argument is a list of usernames with at least one
-    username, and more than one if this is a joint submission (where
-    the submission username was a concatenation of usernames separated
-    by "+").
-
-    The `checker' function is called with the current directory as
-    "<active-assignment>/<username(s)>/ATTEMPT", and the submission is
-    saved in the file "handin", and the timeout clock is reset to the
-    value of the 'session-timeout configuration.  The checker function
-    can change "handin", and it can create additional files in this
-    directory.  (Extra files in the current directory will be
-    preserved as it is later renamed to "SUCCESS-0", and copied to the
-    submission's root ("<active-assignment>/<username(s)>/"), etc.)
-    To hide generated files from the HTTPS status web server
-    interface, put the files in a subdirectory, it is preserved but
-    hidden from the status interface.
-
-    The checker should return a string, such as "handin.scm", to use
-    in naming the submission file, or `#f' to indicate that he file
-    should be deleted (eg, when the checker alrady created the
-    submission file(s) in a different place).
-
-    Alternatively, the module can bind `checker' to a list of three
-    procedures: a pre-checker, a checker, and a post-checker.  All
-    three are applied in exactly the same way as the checker (same
-    arguments, and always within the submission directory), except
-    that:
-    - If there was an error during the pre-checker, and the submission
-      directory does not have a "SUCCESS-*" directory, then the whole
-      submission directory is removed.  This is useful for checking
-      that the user/s are valid -- if you allow a submission only when
-      `users' is '("foo" "bar"), and "foo" tries to submit alone, then
-      the submission directory for "foo" should be removed to allow a
-      proper submission later.  Note that the timeout clock is reset
-      only once, before the pre-checker is used.
-    - The post-checker is used at the end of the process, after the
-      "ATTEMPT" directory was renamed to "SUCCESS-0".  At this stage,
-      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
-      sending a `receipt' email.
-    To specify only pre/post-checker, use `#f' for the one you want to
-    omit.
-
-  * "<[in]active-assignment>/<user(s)>/<filename>" (if submitted) ---
-    the most recent submission for <[in]active-assignment> by
-    <user(s)> 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(s)>" is actually "<user1>+<user2>" etc.  Also, if the
-    cleanup process was interrupted (by a machine failure, etc.), the
-    submission may actually be in "SUCCESS-n" as described above, but
-    will move up when the server performs a cleanup (or when
-    restarted).
-
-  * "<[in]active-assignment>/<user(s)>/grade" (optional) ---
-    <user(s)>'s grade for <[in]active-assignment>, to be reported by
-    the HTTPS status web server
-
-  * "<[in]active-assignment>/solution*" --- the solution to the
-    assignment, made available by the status server to any user who
-    logs in.  The solution can be either a file or a directory with a
-    name that begins with "solution".  In the first case, the status
-    web server will have a "Solution" link to the file, and in the
-    second case, all files in the "solution*" directory will be listed
-    and accessible.
-
-The server can be run within either MzScheme or MrEd, but "utils.ss"
-requires MrEd (which means that `checker' modules will likely require
-the server to run under MrEd).  It is best to use MrEd3m so memory
-accounting is possible and the server will be protected from memory
-related crashes.
-
-The server currently provides no mechanism for a graceful shutdown,
-but terminating the server is no worse than a network outage.  (In
-particular, no data should be lost.)  The server reloads the
-configuration file, checker modules etc, so there should not be any
-need to restart it for reconfigurations.
-
-The client and server are designed to be robust against network
-problems and timeouts.  The client-side tool always provides a
-"cancel" button for any network transaction.  For handins, "cancel" is
-guaranteed to work up to the point that the client sends a "commit"
-command; this command is sent only after the server is ready to record
-the submission (having run it through the checker, if any), but before
-renaming "ATTEMPT".  Also, the server responds to a commit with "ok"
-only after it has written the file.  Thus, when the client-side tool
-reports that the handin was successful, the report is reliable.
-Meanwhile, the tool can also report successful cancels most of the
-time.  In the (normally brief) time between a commit and an "ok"
-response, the tool gives the student a suitable warning that the
-cancel is unreliable.
-
-To minimize human error, the number of active assignments should be
-limited to one whenever possible.  When multiple assignments are
-active, design a checker to help ensure that the student has selected
-the correct assignment in the handin dialog.
-
-A student can download his/her own submissions through a web server
-that runs concurrently with the handin server.  The starting URL is
-
-  https://SERVER:PORT/servlets/status.ss
-
-to obtain a list of all assignments, or
-
-  https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT
-
-to start with a specific assignment (named ASSIGNMENT).  The default
-PORT is 7980.
-
-
-Checker Utilities:
-==================
-
-The checker utilities are provided to make writing checker functions.
-They are provided in a few layers, each layer provides new
-functionality in addition to the lower one.  These modules are (in
-order):
-
-* mzlib/sandbox.ss -- basic sandbox evaluation utilities.  This is in
-  MzLib since it can be used independently.  (See the MzLib manual for
-  details.)
-
-* sandbox.ss -- a wrapper that configures MzLib's sandbox for the
-  handin server.
-
-* utils.ss -- additional utilities for dealing with handin
-  submissions, as well as a few helpers for testing code.
-
-* checker.ss -- this layer automates the task of creating a checker
-  function (in "<active-assignment>/checker.ss" modules) to cope with
-  common submission situations.
-
-The following sections describe each of these modules.
-
-
-_sandbox.ss_
-------------
-
-This is just a wrapper around the sandbox engine from MzLib.  It
-configures it for use with the handin server.
-
-
-_utils.ss_
-----------
-
-> (get-conf key)
-  Returns a value from the configuration file (useful for reading
-  things like field names etc)
-
-> (unpack-submission bytes)
-  Returns two text% objects corresponding to the submitted definitions
-  and interactions windows.
-
-> (make-evaluator/submission language teachpack-paths bytes)
-  Like `make-evaluator', but the definitions content is supplied as a
-  submission byte string.  The byte string is opened for reading, with
-  line-counting enabled.
-
-  See the "sandbox.ss" MzLib library for information on
-  `make-evaluator'.
-
-> (call-with-evaluator language teachpack-paths input-program proc)
-  Calls `proc' with an evaluator for the given language, teachpack
-  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
-  `set-run-status' with "executing your code", and it catches all
-  exceptions to re-raise them in a form suitable as a submission
-  error.
-
-> (call-with-evaluator/submission language teachpack-paths bytes proc)
-  Like `call-with-evaluator', but the definitions content is supplied
-  as a submission string.  The byte string is opened for reading, with
-  line-counting enabled.
-
-> (evaluate-all source input-port eval)
-  Like `load' on an input port.
-
-> (evaluate-submission bytes eval)
-  Like `load' on a submission byte string.
-
-> (check-proc eval expect-v compare-proc proc-name arg ...)
-  Calls the function named `proc-name' using the evaluator `eval',
-  giving it the (unquoted) arguments `arg'...  Let `result-v' be the
-  result of the call; unless `(compare-proc result-v expect-v)' is
-  true, an exception is raised.
-
-  Every exception or result mismatch during the call to `check-proc'
-  phrased suitably for the handin client.
-
-> (check-defined eval name)
-  Checks whether `name' is defined in the evaluator `eval', and raises
-  an error if not (suitably phrased for the handin client).  If it is
-  defined as non-syntax, its value is returned.  Warning: in the
-  beginner language level, procedure definitions are bound as syntax.
-
-> (look-for-tests text name n)
-  Inspects the given text% object to determine whether it contains at
-  least `n' tests for the function `name'.  The tests must be
-  top-level expressions.
-
-> (user-construct eval name arg ...)
-  Like `check-proc', but with no result checking.  This function is
-  often useful for calling a student-defined constructor.
-
-> test-history-enabled
-  Parameter that controls how run-time errors are reported to the
-  handin client.  If the parameter's value is true, then the complete
-  sequence of tested expressions is reported to the handin client for
-  any test failure.  Set this parameter to true when testing programs
-  that use state.
-
-> (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 can be the symbol
-  'final, which will be used as the text on the handin dialog after a
-  successful submission instead of "Handin successful." (useful for
-  submissions that were saved, but had problems); finally, `styles'
-  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 or ask
-  confirmation.
-
-> (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
-  instructor-supplied test was being executed when the session ran out
-  of memory.  This status is only used when per-session memory limits
-  are supported (i.e., under MrEd3m or MzScheme3m with memory
-  accounting), but in both cases, a string value will also be passed
-  on to `message' above.
-
-> (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.
-
-> (log-line fmt args ...)
-  Produces a line in the server log file, using the given format
-  string and arguments.  All this actually does, is arrange to print
-  the line fast (to avoid mixing lines from different threads) to the
-  error port, and flush it.  (The log port will prefix all lines with
-  a time stamp and connection identifier.)
-
-> (timeout-control msg)
-  Control the timeout for this session.  The timeout is initialized by
-  the value of the 'session-timeout configuration entry, and the
-  checker can use this procedure to further control it: if msg is
-  'reset the timeout is reset to 'session-timeout seconds; if msg is a
-  number the timeout will be set to that many seconds in the future.
-  The timeout can be completely disabled by `(timeout-control #f)'.
-  (Note that before the checker is used (after the pre-checker, if
-  specified), the timer will be reset to the 'session-timeout value.)
-
-
-_checker.ss_
-------------
-
-The "checker.ss" module provides a higher-level of utilities, helpful
-in implementing `checker' functions that are intended for a more
-automated system.  This module is a language module -- a typical
-checker that uses it looks like this:
-
-   (module checker (lib "checker.ss" "handin-server")
-     (check: :language  'intermediate
-             :users     pairs-or-singles-with-warning
-             :coverage? #t
-       (!procedure Fahrenheit->Celsius 1)
-       (!test (Fahrenheit->Celsius  32)   0)
-       (!test (Fahrenheit->Celsius 212) 100)
-       (!test (Fahrenheit->Celsius  -4) -20)
-       ...))
-
-> (check: :key val ... body ...)
-  Construct a checker procedure.
-
-The `check:' macro will construct (and provide) an appropriate checker
-function, using keywords for features that you want, the body of the
-checker can contain arbitrary code, using all utilities from
-"utils.ss" (see above), as well as additional ones (see below).
-
-Keywords for configuring `check:':
-
-* :users -- specification of users that are acceptable for
-  submission.  Can be either a list of user lists, each representing a
-  known team, or procedure which will accept a list of users and throw
-  an exception if they are unacceptable.  The default is to accept
-  only single-user submissions.  `pairs-or-singles-with-warning' is a
-  useful value for pair submission where the pairs are unknown (see
-  below).
-
-* :eval? -- whether submissions should be evaluated.  Defaults to
-  `#t'.  Note that if it is specified as `#f', then the checker body
-  will not be able to run any tests on the code, unless it contains
-  code that performs some evaluation (eg, using the facilities of
-  "utils.ss").
-
-* :language -- the language that is used for evaluating submissions,
-  same as the `language' argument for `make-evaluator' (see
-  "sandbox.ss").  There is no default for this, so it must be set or
-  an error is raised.
-
-* :teachpacks -- teachpacks for evaluating submissions, same as the
-  `teachpacks' argument for `make-evaluator' (see "sandbox.ss").
-  Defaults to null -- no teachpacks.
-
-* :create-text? -- if true, then a textual version of the submission
-  is saved as "text.scm" in a "grading" subdirectory (or any suffix
-  that is specified by :output below, for example "hw.java" is
-  converted into a textual "grading/text.java").  This is intended for
-  printouts and grading, and is in a subdirectory so students will not
-  see it on the status web server.  Defaults to `#t'.
-
-* :untabify? -- if true, then tabs are converted to spaces, assuming a
-  standard tab width of 8 places.  This is needed for a correct
-  computation of line lengths, but note that DrScheme does not insert
-  tabs in Scheme mode.  Defaults to `#t'.
-
-* :textualize? -- if true, then all submissions are converted to text,
-  trying to convert objects like comment boxes and test cases to some
-  form of text.  Defaults to `#f', meaning that an exception is raised
-  for submissions that are not all text.
-
-* :maxwidth -- a number that specifies maximum line lengths for
-  submissions (a helpful feature for reading student code).  Defaults
-  to 79.  This feature can be disabled if set to `#f'.
-
-* :output -- the name of the original handin file (unrelated to the
-  text-converted files).  Defaults to "hw.scm".  (The suffix changes
-  the defaults of `:markup-prefix' and `:prefix-re' below.)  Can be
-  `#f' for removing the original file after processing.
-
-* :multi-file -- by default, this is set to `#f', which means that
-  only DrScheme is used to send submissions as usual.  See
-  "Multiple-file submissions" below for setting up multi-file
-  submissions.
-
-* :names-checker -- used for multi-file submissions; see
-  "Multiple-file submissions" below for details.
-
-* :markup-prefix -- used as the prefix for :student-lines and
-  :extra-lines below.  The default is ";;> " or "//> ", depending on
-  the suffix of :output above.  (Note: if you change this, make sure
-  to change :prefix-re too.)
-
-* :prefix-re -- used to identify lines with markup (";>" or "//>"
-  etc), so students cannot fool the system by writing marked-up code.
-  The default is ";>" or "//>", depending on the suffix of :output
-  above.
-
-* :student-line -- when a submission is converted to text, it begins
-  with lines describing the students that have submitted it; this is
-  used to specify the format of these lines.  It is a string with
-  holes that that `user-substs' (see below) fills out.  The default is
-  "Student: {username} ({Full Name} <{Email}>)", which requires a
-  "Full Name" and "Email" entries in the server's extra-fields
-  configuration.  These lines are prefixed with ";;> " or the prefix
-  specified by :makup-prefix above.
-
-* :extra-lines -- a list of lines to add after the student lines, all
-  with a ";;> " or :markup-prefix too.  Defaults to a single line:
-  "Maximum points for this assignment: <+100>".  (Can use
-  "{submission}" for the submission directory.)  See also
-  `add-header-line!' below.
-
-* :user-error-message -- a string that is used to report an error that
-  occurred 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.  The default is "Error in your code --\n~a".  Useful
-  examples of these messages:
-
-    "There is an error in your program, hit \"Run\" to debug"
-    "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).
-
-* :coverage? -- collect coverage information when evaluating the
-  submission.  This will cause an error if some input is not covered.
-  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.
-
-Within the body of `check:', `users' and `submission' will be bound to
-the checker arguments -- a (sorted) list of usernames and the
-submission as a byte string.  In addition to the functionality below,
-you can use `((submission-eval) expr)' to evaluate expressions in the
-submitted code context, and you can use `(with-submission-bindings (id
-...) body ...)' to evaluate the body when `id's are bound to their
-value from the submission code.
-
-> (pre: body ...)
-> (post: body ...)
-  These two macros define a pre- and a post-checker.  In their body,
-  `users' and `submission' are bound as in `check:', but there is
-  nothing else special about these.  See the description of the
-  `pre-checker' and `post-checker' values for what can be done with
-  these, and note that the check for valid users is always first.  An
-  example for a sophisticated `post:' block is below -- it will first
-  disable timeouts for this session, then it will send a email with a
-  submission receipt, with CC to the TA (assuming a single TA), and
-  pop-up a message telling the student about it:
-
-  (require (lib "sendmail.ss" "net"))
-  (post:
-    (define info
-      (format "hw.scm: ~a ~a"
-              (file-size "hw.scm")
-              (file-or-directory-modify-seconds "hw.scm")))
-    (timeout-control 'disable)
-    (log-line "Sending a receipt: ~a" info)
-    (send-mail-message
-     "course-staff@university.edu"
-     "Submission Receipt"
-     (map (lambda (user) (user-substs user "{Full Name} <{Email}>"))
-          users)
-     (list (user-substs (car users) "{TA Name} <{TA Email}>"))
-     null
-     `("Your submission was received" ,info))
-    (message (string-append
-              "Your submission was successfully saved."
-              "  You will get an email receipt within 30 minutes;"
-              " if not, please contact the course staff.")
-             '(ok)))
-
-> submission-eval
-  A parameter that holds an evaluation procedure for evaluating code
-  in the submission context.
-
-> (user-data user)
-  Returns a user information given a username.  The returned
-  information is a list of strings that corresponds to the configured
-  `extra-fields' (see above).
-
-> (user-substs user str)
-  Given a username, this procedure will lookup the user's extra-fields
-  information (see above) and then substitute field names in {braces}
-  by the corresponding value.  An error will be signaled if a field
-  name is missing.  Also, "{username}" will always be replaced by the
-  username and "{submission}" by the current submission directory.
-
-  This is used to process the `:student-line' value in the checker,
-  but it is provided for additional uses.  See the above sample code
-  for `post:' for using this procedure.
-
-> (pairs-or-singles-with-warning users)
-  This procedure is intended for use as the :users entry in a checker.
-  It will do nothing if there are two users, and throw an error if
-  there are more.  If there is a single user, then the user will be
-  asked to verify a single submission -- if the students cancels, then
-  an exception is raised so the submission directory is retracted.  If
-  the student approves this, the question is not repeated (this is
-  marked by creating a directory with a known name).  This is useful
-  for cases where you want to allow free pair submissions -- students
-  will often try to submit their work alone, and later on re-submit
-  with a partner.
-
-> (teams-in-file team-file)
-  This procedure *returns* a procedure that can be used for the :users
-  entry in a checker.  The team file (relative from the server's main
-  directory) is expected to have user entries -- a sequence of
-  s-expressions, each one a string or a list of strings.  The
-  resulting procedure will allow submission only by teams that are
-  specified in this file.  Furthermore, if this file is modified, the
-  new contents will be used immediately, so there is no need to
-  restart the server of you want to change student teams.  (But
-  remember that if you change ("foo" "bar") to ("foo" "baz"), and
-  there is already a "bar+foo" submission directory, then the system
-  will not allow "foo" to submit with "bar".)
-
-> (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 (in addition
-  to the `:extra-lines' setting).  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.
-
-> (!defined id ...)
-  A macro that checks that the given identifiers are defined in the
-  (evaluated) submission, and throws an error otherwise.
-
-> (!procedure id [arity])
-> (!procedure* expr [arity])
-  `!procedure' checks that `id' is defined, and is bound to a
-  procedure; `!*procedure' is similar but omits the defined check,
-  making it usable with any expression (which is evaluated in the
-  submission context).
-
-> (!integer id)
-> (!integer* expr)
-  Similar to `!procedure' and `!procedure*' for integers.
-
-> (!test expr)
-> (!test expr result [equal?])
-  The first form checks that the given expression evaluates to a
-  non-`#f' value in the submission context, throwing an error
-  otherwise.  The second form compares the result of evaluation,
-  requiring it to be equal to `result' (optionally specifying an
-  equality procedure).  Note that the `result' and `equal?' forms are
-  *not* evaluated in the submission context.
-
-> (!all-covered [proc])
-  When coverage information is enabled (see `:coverage?' above), this
-  procedure checks the collected coverage information and throws an
-  error with source information if some code is left uncovered.  If
-  the optional procedure argument is provided, it is applied on a
-  string argument that describes the location of the uncovered
-  expression ("<line>:<col>", "#<char-pos>", or "(unknown position)")
-  instead of throwing an error.  The collected information includes
-  only execution coverage by submission code, excluding additional
-  checker tests.  You do not have to call this explicitly -- it is
-  called at the end of the process automatically when `:coverage?' is
-  enabled.  It is made available so you can call it earlier (eg,
-  before testing) to show clients a coverage error first, or if you
-  want to avoid an error.  For example, you can do this:
-
-    (!all-covered
-     (lambda (where)
-       (case (message (string-append
-                       "Incomplete coverage at "where", do you want"
-                       " to save this submission with 10% penalty?"))
-         [(yes) (add-header-line! "No full coverage <*90%>")
-                (message "Handin saved with penalty.")]
-         [else (error "aborting submission")])))
-
-
-Multiple-File Submissions:
-==========================
-
-By default, the system is set up for submissions of single a single
-file, straight fom DrScheme using the handin-client.  There is some
-support for multi-file submissions in "checker.ss" and in the
-handin-client -- it is possible to submit multiple files, and have the
-system generate a single file that is the concatenation of all
-submission files (used only with text files).  To set up multi-file
-submissions, do the following:
-
-* Add a `:multi-file' keyword in `check:', and as a value, use the
-  suffix that should be used for the single concatenated output file.
-
-* You can also add a `:names-checker' keyword -- the value can be a
-  regexp that all submitted files must follow (eg, ".*[.]scm$"), or a
-  list of expected file names.  Alternatively, it can be a 1-argument
-  procedure that will receive the (sorted) list of submitted files and
-  can throw an error if some files are missing or some files are
-  forbidden.
-
-* In the "info.ss" file of the handin-client you need to set
-  `enable-multifile-handin' to `#t', and adjust `selection-default' to
-  patterns that are common to your course.  (It can be a single
-  pattern, or a list of them.)
-
-On the server side, each submission is saved in a file called "raw",
-which contains all submitted files.  In the "grading" directory, you
-will get a "text.<sfx>" file ("<sfx>" is the suffix that is used as a
-value for `:multi-file') that contains all submitted files with clear
-separators.  A possible confusion is that every submission is a
-complete set of files that overwrites any existing submission -- but
-students may think that the server accumulates incoming files.  To
-avoid such confusion, when a submission arrives an there is already an
-existing previous submission, the contents is compared, and if there
-are files that existed in the old submission but not in the new ones,
-the student will see a warning pop-up that allows aborting the
-submission.
-
-On the client side, students will have an additional file-menu entry
-for submitting multiple files, which pops up a dialog that can be used
-to submit multiple files.  In this dialog, students choose their
-working directory, and the `selection-default' entry from the
-"handin-client/info.ss" file specifies a few patterns that can be used
-to automatically select files.  The dialog provides all handin-related
-functionality that is available in DrScheme.  For further convenience,
-it can be used as a standalone application: in the account management
-dialog, the "Un/Install" tab has a button that will ask for a
-directory where it will create an executable for the multi-file
-submission utility -- the resulting executable can be used outside of
-DrScheme (but PLT Scheme is still required, so it cannot be
-uninstalled).
-
-
-Auto-Updater:
-=============
-
-The handin-client has code that can be used for automatic updating of
-clients.  This can be useful for courses where you distribute some
-additional functionality (collections, teachpacks, language-levels
-etc), and this functionality can change (or expected to change, for
-example, distributing per-homework teachpacks).
-
-To enable this, uncomment the relevant part of the "info.ss" file in
-the client code, it has the following three keys: `enable-auto-update'
-that turns this facility on, `version-filename' and `package-filename'
-which are the expected file names of the version file and the .plt
-file relative to the course web address (the value of the
-`web-address' key).  Also, include in your client collection a
-"version" file that contains a single number that is its version -- a
-big integer that holds the time of this collection in a YYYYMMDDHHMM
-format.
-
-When students install the client, every time DrScheme starts, it will
-automatically check the version from the web page (as specified by the
-`web-address' and `version-filename' keys), and if that contains a
-bigger number, it will offer the students to download and install the
-new version.  So, every time you want to distribute a new version, you
-build a new .plt file that contains a new version file, then copy
-these version and .plt files to your web page, and students will be
-notified automatically.  Note: to get this to work, you need to create
-your .plt file using mzc's `--replace' flag, so it will be possible to
-overwrite existing files.  (Also note that there is no way to delete
-files when a new .plt is installed.)
diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss
deleted file mode 100644
index be5d9e083c..0000000000
--- a/collects/handin-server/handin-server.ss
+++ /dev/null
@@ -1,693 +0,0 @@
-(module handin-server mzscheme
-  (require (lib "thread.ss")
-           (lib "port.ss")
-           (lib "mzssl.ss" "openssl")
-           (lib "file.ss")
-           (lib "date.ss")
-           (lib "list.ss")
-           (lib "string.ss")
-           "private/logger.ss"
-           "private/config.ss"
-           "private/lock.ss"
-           "private/md5.ss"
-           "private/run-status.ss"
-           "private/reloadable.ss"
-           "private/hooker.ss"
-           "web-status-server.ss"
-           ;; this sets some global parameter values, and this needs
-           ;; to be done in the main thread, rather than later in a
-           ;; user session thread (that will make the global changes
-           ;; not to be global.)
-           "sandbox.ss")
-
-  (install-logger-port)
-
-  ;; errors to the user: no need for a "foo: " prefix
-  (define (error* fmt . args)
-    (error (apply format fmt args)))
-
-  (define (write+flush port . xs)
-    (for-each (lambda (x) (write x port) (newline port)) xs)
-    (flush-output port))
-
-  (define-struct alist (name l))
-  (define (a-set! alist key val)
-    (let ([l (alist-l alist)])
-      (cond [(assq key l) => (lambda (p) (set-box! (cdr p) val))]
-            [else (set-alist-l! alist (cons (cons key (box val)) l))])))
-  (define (a-ref alist key . default)
-    (cond [(assq key (alist-l alist)) => (lambda (x) (unbox (cdr x)))]
-          [(pair? default) (car default)]
-          [else (error (alist-name alist) "no value for `~s'" key)]))
-
-  (define orig-custodian (current-custodian))
-
-  ;; On startup, check that the users file is not locked:
-  (put-preferences null null
-    (lambda (f)
-      (delete-file f)
-      (put-preferences null null
-                       (lambda (f)
-                         (error 'handin-server
-                                "unable to clean up lock file: ~s" f))
-                       "users.ss"))
-    "users.ss")
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (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 (get-conf 'max-upload-keep))
-            (begin (make-success-dir-available (add1 n))
-                   (rename-file-or-directory name (success-dir (add1 n))))
-            (delete-directory/files name)))))
-
-  (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR)))
-  (define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+"))))
-  (define SUCCESS-GOOD (map success-dir '(0 1)))
-
-  (define (cleanup-submission-body)
-    ;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it
-    ;; means that there was a failed submission and the next one will
-    ;; re-create ATTEMPT.
-    (let* ([dirlist (map path->string (directory-list))]
-           [dir (sort (filter (lambda (d)
-                                (and (directory-exists? d)
-                                     (regexp-match SUCCESS-RE d)))
-                              dirlist)
-                 string<?)]
-           [dir (and (pair? dir) (car dir))])
-      (when dir
-        (unless (member dir SUCCESS-GOOD)
-          (log-line "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
-                    (build-path (current-directory) dir)))
-        ;; We have a submission directory -- copy all newer things (extra
-        ;; things that exist in the main submission directory but not in
-        ;; SUCCESS, or things that are newer in the main submission
-        ;; directory are kept (but subdirs in SUCCESS will are copied as
-        ;; is))
-        (for-each
-         (lambda (f)
-           (define dir/f (build-path dir f))
-           (cond [(not (or (file-exists? f) (directory-exists? f)))
-                  ;; f is in dir but not in the working directory
-                  (copy-directory/files dir/f f)]
-                 [(or (<= (file-or-directory-modify-seconds f)
-                          (file-or-directory-modify-seconds dir/f))
-                      (and (file-exists? f) (file-exists? dir/f)
-                           (not (= (file-size f) (file-size dir/f)))))
-                  ;; f is newer in dir than in the working directory
-                  (delete-directory/files f)
-                  (copy-directory/files dir/f f)]))
-         (directory-list dir)))))
-
-  (define cleanup-sema (make-semaphore 1))
-  (define (cleanup-submission dir)
-    ;; This is called at a lock cleanup, so it is important that it does not
-    ;; throw an exception, or the whole server will be locked down.  It is
-    ;; invoked just before the lock is released, so fine to assume that we have
-    ;; exclusive access to the directory contents.
-    (with-handlers ([void
-                     (lambda (e)
-                       (log-line "*** ERROR DURING (cleanup-submission ~s) : ~a"
-                                 dir (if (exn? e) (exn-message e) e)))])
-      (when (directory-exists? dir) ; submissions can fail before mkdir
-        (parameterize ([current-directory dir])
-          (call-with-semaphore cleanup-sema cleanup-submission-body)))))
-
-  (define (cleanup-all-submissions)
-    (log-line "Cleaning up all submission directories")
-    (for-each (lambda (pset)
-                (when (directory-exists? pset) ; just in case
-                  (parameterize ([current-directory pset])
-                    (for-each (lambda (sub)
-                                (when (directory-exists? sub) ; filter non-dirs
-                                  (cleanup-submission sub)))
-                              (directory-list)))))
-              (get-conf 'all-dirs)))
-
-  ;; On startup, we scan all submissions, then repeat at random intervals (only
-  ;; if clients connected in that time), and check often for changes in the
-  ;; active/inactive directories and run a cleanup if there was a change
-  (define connection-num 0)
-  (thread (lambda ()
-            (define last-all-dirs #f)
-            (define last-connection-num #f)
-            (let loop ()
-              (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
-                (when (>= n 0)
-                  (let ([new (get-conf 'all-dirs)])
-                    (if (equal? new last-all-dirs)
-                      (begin (sleep 30) (loop (sub1 n)))
-                      (begin (set! last-all-dirs new)
-                             (set! last-connection-num #f))))))
-              (unless (equal? last-connection-num connection-num)
-                (cleanup-all-submissions)
-                (set! last-connection-num connection-num))
-              (loop))))
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define (save-submission s part)
-    (with-output-to-file part
-      (lambda () (display s))))
-
-  (define (users->dirname users)
-    (apply string-append (car users)
-           (map (lambda (u) (string-append "+" u)) (cdr users))))
-
-  (define (accept-specific-submission data r r-safe w)
-    ;; Note: users are always sorted
-    (define users       (a-ref data 'usernames))
-    (define assignments (a-ref data 'assignments))
-    (define assignment  (a-ref data 'assignment))
-    (define dirname     (users->dirname users))
-    (define len #f)
-    (unless (member assignment assignments)
-      (error* "not an active assignment: ~a" assignment))
-    (log-line "assignment for ~a: ~a" users assignment)
-    (hook 'submission-received `([usernames ,users] [assignment ,assignment]))
-    (write+flush w 'ok)
-    (set! len (read r-safe))
-    (unless (and (number? len) (integer? len) (positive? len))
-      (error* "bad length: ~s" len))
-    (unless (len . < . (get-conf 'max-upload))
-      (error* "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
-              (get-conf 'max-upload) len))
-    (parameterize ([current-directory (assignment<->dir assignment)])
-      (wait-for-lock dirname
-        (let ([dir (build-path (current-directory) dirname)])
-          (lambda () (cleanup-submission dir))))
-      (when (and (pair? users) (pair? (cdr users)))
-        ;; two or more users -- lock each one
-        (for-each wait-for-lock users))
-      (write+flush w 'go)
-      (unless (regexp-match #rx"[$]" r-safe)
-        (error* "did not find start-of-content marker"))
-      (let ([s (read-bytes len r)])
-        (unless (and (bytes? s) (= (bytes-length s) len))
-          (error* "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* "bad submission: ~a has an existing submission (~a)"
-                          d dir)))
-              (regexp-split #rx" *[+] *" (path->string dir))))
-           (directory-list))
-          (make-directory dirname))
-        (parameterize ([current-directory dirname]
-                       [current-messenger
-                        (case-lambda
-                          [(msg) (write+flush w 'message msg)]
-                          [(msg styles)
-                           (if (eq? 'final styles)
-                             (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))
-          (make-directory ATTEMPT-DIR)
-          (save-submission s (build-path ATTEMPT-DIR "handin"))
-          (timeout-control 'reset)
-          (log-line "checking ~a for ~a" assignment users)
-          (let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
-                 [checker* (and (file-exists? checker*)
-                                (parameterize ([current-directory server-dir])
-                                  (auto-reload-value
-                                   `(file ,(path->string checker*))
-                                   'checker)))])
-            (define-values (pre checker post)
-              (cond [(not checker*) (values #f #f #f)]
-                    [(procedure? checker*) (values #f checker* #f)]
-                    [(and (list? checker*) (= 3 (length checker*)))
-                     (apply values checker*)]
-                    [else (error* "bad checker value: ~e" checker*)]))
-            (when pre
-              (let ([dir (current-directory)])
-                (with-handlers
-                    ([void (lambda (e)
-                             (parameterize ([current-directory dir])
-                               (unless (ormap (lambda (d)
-                                                (and (directory-exists? d)
-                                                     (regexp-match
-                                                      SUCCESS-RE
-                                                      (path->string d))))
-                                              (directory-list))
-                                 (parameterize ([current-directory ".."])
-                                   (when (directory-exists? dirname)
-                                     (delete-directory/files dirname)))))
-                             (raise e))])
-                  (parameterize ([current-directory ATTEMPT-DIR])
-                    (pre users s)))))
-            (let ([part (if checker
-                          (parameterize ([current-directory ATTEMPT-DIR])
-                            (checker users s))
-                          (get-conf 'default-file-name))])
-              (write+flush w 'confirm)
-              (let ([v (read (make-limited-input-port r 50))])
-                (if (eq? v 'check)
-                  (begin
-                    (log-line "saving ~a for ~a" assignment users)
-                    (parameterize ([current-directory ATTEMPT-DIR])
-                      (cond [part (unless (equal? part "handin")
-                                    (rename-file-or-directory "handin" part))]
-                            [(file-exists? "handin") (delete-file "handin")]))
-                    ;; 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))
-                    (hook 'submission-committed
-                          `([usernames ,users] [assignment ,assignment]))
-                    (when post
-                      (parameterize ([current-directory (success-dir 0)])
-                        (post users s))))
-                  (error* "upload not confirmed: ~s" v)))))))))
-
-  (define (retrieve-specific-submission data w)
-    ;; Note: users are always sorted
-    (define users       (a-ref data 'usernames))
-    (define assignments (a-ref data 'assignments))
-    (define assignment  (a-ref data 'assignment))
-    (define dirname     (users->dirname users))
-    (define submission-dir (build-path (assignment<->dir assignment) dirname))
-    (unless (member assignment assignments)
-      (error* "not an active assignment: ~a" assignment))
-    (unless (directory-exists? submission-dir)
-      (error* "no ~a submission directory for ~a" assignment users))
-    (log-line "retrieving assignment for ~a: ~a" users assignment)
-    (parameterize ([current-directory submission-dir])
-      (define magics '(#"WXME" 
-                       #"<<<MULTI-SUBMISSION-FILE>>>" 
-                       #"#reader(lib\"read.ss\"\"wxme\")WXME"))
-      (define mlen (apply max (map bytes-length magics)))
-      (define file
-        ;; find the newest wxme file
-        (let loop ([files (directory-list)] [file #f] [time #f])
-          (if (null? files)
-            file
-            (let ([f (car files)])
-              (if (and (file-exists? f)
-                       (let ([m (with-input-from-file f
-                                  (lambda () (read-bytes mlen)))])
-                         (ormap (lambda (magic)
-                                  (equal? magic
-                                          (subbytes m 0 (bytes-length magic))))
-                                magics))
-                       (or (not file)
-                           (> (file-or-directory-modify-seconds f) time)))
-                (loop (cdr files) f (file-or-directory-modify-seconds f))
-                (loop (cdr files) file time))))))
-      (if file
-        (let ([len (file-size file)])
-          (write+flush w len)
-          (display "$" w)
-          (display (with-input-from-file file (lambda () (read-bytes len))) w)
-          (flush-output w)
-          (hook 'submission-retrieved
-                `([usernames ,users] [assignment ,assignment])))
-        (error* "no ~a submission file found for ~a" assignment users))))
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define (put-user-data username data)
-    ;; Although we don't have to worry about trashing the
-    ;;  prefs file, we do have to worry about a thread
-    ;;  getting killed while it locks the pref file.
-    ;; Avoid the problem by using orig-custodian.
-    (call-in-nested-thread
-     (lambda ()
-       (put-preferences
-        (list (string->symbol username)) (list data)
-        (lambda (f)
-          (error* "user database busy; please try again, and alert the adminstrator if problems persist"))
-        "users.ss"))
-     orig-custodian))
-
-  (define (get-user-data username)
-    (get-preference (string->symbol username) (lambda () #f) #f "users.ss"))
-  (define (check-field value field-re field-name field-desc)
-    (unless (cond [(or (string? field-re) (regexp? field-re))
-                   (regexp-match field-re value)]
-                  [(list? field-re) (member value field-re)]
-                  [(not field-re) #t]
-                  [(eq? field-re '-) #t] ; -> hidden field, no check
-                  [else (error* "bad spec: field-regexp is ~e" field-re)])
-      (error* "bad ~a: \"~a\"~a" field-name value
-              (if field-desc (format "; need ~a" field-desc) ""))))
-
-  ;; Utility for the next two functions: reconstruct a full list of
-  ;; extra-fields from user-fields, using "" for hidden fields
-  (define (add-hidden-to-user-fields user-fields)
-    (let ([user-field-name->user-field
-           (map cons (get-conf 'user-fields) user-fields)])
-      (map (lambda (f)
-             (cond [(assq f user-field-name->user-field) => cdr]
-                   [else ""]))
-           (get-conf 'extra-fields))))
-
-  (define (add-new-user data)
-    (define username     (a-ref data 'username/s))
-    (define passwd       (a-ref data 'password))
-    (define user-fields  (a-ref data 'user-fields))
-    (define extra-fields (add-hidden-to-user-fields user-fields))
-    (unless (get-conf 'allow-new-users)
-      (error* "new users not allowed: ~a" username))
-    (check-field username (get-conf 'user-regexp) "username"
-                 (get-conf 'user-desc))
-    ;; Since we're going to use the username in paths, and + to split names:
-    (when (regexp-match #rx"[+/\\:|\"<>]" username)
-      (error* "username must not contain these characters: + / \\ : | \" < >"))
-    (when (regexp-match
-           #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
-           (string-foldcase username))
-      (error* "username must not be a Windows special file name"))
-    (when (regexp-match #rx"^[ .]|[ .]$" username)
-      (error* "username must not begin or end with a space or period"))
-    (when (regexp-match #rx"^solution" username)
-      (error* "the username prefix \"solution\" is reserved"))
-    (when (string=? "checker.ss" username)
-      (error* "the username \"checker.ss\" is reserved"))
-    (when (get-user-data username)
-      (error* "username already exists: `~a'" username))
-    (for-each (lambda (str info)
-                (check-field str (cadr info) (car info) (caddr info)))
-              extra-fields (get-conf 'extra-fields))
-    (wait-for-lock "+newuser+")
-    (log-line "create user: ~a" username)
-    (hook 'user-create `([username ,username] [fields ,extra-fields]))
-    (put-user-data username (cons passwd extra-fields)))
-
-  (define (change-user-info data)
-    (define usernames    (a-ref data 'usernames))
-    (define user-datas   (a-ref data 'user-datas))
-    (define passwd       (a-ref data 'new-password))
-    (define user-fields  (a-ref data 'user-fields))
-    (define extra-fields (add-hidden-to-user-fields user-fields))
-    (unless (= 1 (length usernames))
-      (error* "cannot change a password for multiple users: ~a" usernames))
-    ;; the new data is the same as the old one for every empty string (includes
-    ;; hidden fields)
-    (let* ([username (car usernames)]
-           [old-data (car user-datas)]
-           [new-data (map (lambda (old new) (if (equal? "" new) old new))
-                          old-data (cons passwd extra-fields))])
-      (unless (or (get-conf 'allow-change-info)
-                  (equal? (cdr new-data) (cdr old-data)))
-        (error* "changing information not allowed: ~a" username))
-      (when (equal? new-data old-data)
-        (error* "no fields changed: ~a" username))
-      (for-each (lambda (str info)
-                  (check-field str (cadr info) (car info) (caddr info)))
-                (cdr new-data) (get-conf 'extra-fields))
-      (log-line "change info for ~a ~s -> ~s" username old-data new-data)
-      (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change
-        (hook 'user-change `([username ,username]
-                             [old ,(cdr old-data)]
-                             [new ,(cdr new-data)])))
-      (put-user-data username new-data)))
-
-  (define (get-user-info data)
-    (define usernames  (a-ref data 'usernames))
-    (unless (= 1 (length usernames))
-      (error* "cannot get user-info for multiple users: ~a" usernames))
-    ;; filter out hidden fields
-    (let ([all-data (cdar (a-ref data 'user-datas))])
-      (filter values (map (lambda (d f)
-                            (and (memq f (get-conf 'user-fields)) d))
-                          all-data (get-conf 'extra-fields)))))
-
-  (define crypt
-    (let ([c #f] [sema (make-semaphore 1)])
-      ;; use only when needed so it doesn't blow up on non-unix platforms
-      (lambda (passwd salt)
-        (unless c (set! c (dynamic-require '(lib "crypt.ss" "ffi") 'crypt)))
-        ;; crypt is not reentrant
-        (call-with-semaphore sema
-          (lambda () (bytes->string/utf-8 (c passwd salt)))))))
-  (define (has-password? raw md5 passwords)
-    (define (good? passwd)
-      (define (bad-password msg)
-        (log-line "ERROR: ~a -- ~s" msg passwd)
-        (error* "bad password in user database"))
-      (cond [(string? passwd) (equal? md5 passwd)]
-            [(and (list? passwd) (= 2 (length passwd))
-                  (symbol? (car passwd)) (string? (cadr passwd)))
-             (case (car passwd)
-               [(plaintext) (equal? raw (cadr passwd))]
-               [(unix)
-                (let ([salt (regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)"
-                                          (cadr passwd))])
-                  (unless salt (bad-password "badly formatted unix password"))
-                  (equal? (crypt raw (car salt)) (cadr passwd)))]
-               [else (bad-password "bad password type in user database")])]
-            [else (bad-password "bad password value in user database")]))
-    (or (member md5 passwords) ; very cheap search first
-        (ormap good? passwords)))
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define (handle-connection r r-safe w)
-    (define msg #f)
-    (define active-assignments (assignment-list))
-    (define data
-      (make-alist 'protocol-data `((assignments . ,(box active-assignments)))))
-    (define (perror fmt . args) (apply error 'handin-protocol fmt args))
-    (let loop ()
-      (set! msg (read r-safe))
-      (case msg
-        ;; ----------------------------------------
-        ;; getting information from the client
-        [(set)
-         (let* ([key (read r-safe)] [val (read r-safe)])
-           (unless (symbol? key) (perror "bad key value: ~e" key))
-           (unless (if (eq? 'user-fields key)
-                     (and (list? val)
-                          (- (length val) (length (get-conf 'user-fields)))
-                          (andmap string? val))
-                     (string? val))
-             (perror "bad value for set: ~e" val))
-           (when (a-ref data key #f) (perror "multiple values for ~e" key))
-           (case key
-             [(username/s)
-              (unless (get-conf 'username-case-sensitive)
-                (set! val (string-foldcase val)))
-              (let ([usernames
-                     ;; Username lists must always be sorted, and never empty
-                     ;; (regexp-split will not return an empty list)
-                     (sort (regexp-split #rx" *[+] *" val) string<?)])
-                (a-set! data 'usernames usernames)
-                (a-set! data 'user-datas (map get-user-data usernames)))]
-             [(password new-password)
-              ;; empty passwords are left empty for change-user-info to re-use
-              ;; an existing password value
-              (when (eq? key 'password) (a-set! data 'raw-password val))
-              (unless (equal? "" val) (set! val (md5 val)))]
-             [(usernames user-datas raw-password assignments)
-              ;; forbid setting these directly
-              (perror "bad key for `set': ~e" key)])
-           (a-set! data key val))
-         (loop)]
-        ;; ----------------------------------------
-        ;; sending information to the client
-        [(get-active-assignments)
-         (write+flush w active-assignments)
-         (loop)]
-        [(get-user-fields)
-         (write+flush w (map car (get-conf 'user-fields)))
-         (loop)]
-        ;; ----------------------------------------
-        ;; action handlers
-        ;; (don't loop back except get-user-info which needs authorization)
-        [(create-user) (add-new-user data)]
-        [(bye) #t] ; <- general disconnection
-        ;; other messages require a login: valid users and a good password
-        [else
-         (when (eof-object? msg)
-           (let ([username/s (a-ref data 'username/s #f)])
-             (apply error 'handin
-                    (if username/s `("hangup (~a)" ,username/s) `("hangup")))))
-         (let ([usernames  (a-ref data 'usernames #f)]
-               [user-datas (a-ref data 'user-datas #f)])
-           (when (or (memq #f user-datas)
-                     (not (has-password?
-                           (a-ref data 'raw-password)
-                           (a-ref data 'password)
-                           (cons (get-conf 'master-password)
-                                 (map car user-datas)))))
-             (log-line "failed login: ~a" (a-ref data 'username/s))
-             (error* "bad username or password for ~a"
-                     (a-ref data 'username/s)))
-           (log-line "login: ~a" usernames)
-           (hook 'login `([usernames ,usernames])))
-         (case msg
-           [(change-user-info) (change-user-info data)]
-           [(save-submission) (accept-specific-submission data r r-safe w)]
-           [(get-submission) (retrieve-specific-submission data w)]
-           [(get-user-info) (write+flush w (get-user-info data)) (loop)]
-           [else (perror "bad message `~a'" msg)])]))
-    (write+flush w 'ok)) ; final confirmation for *all* actions
-
-  (define (assignment-list)
-    (map assignment<->dir (get-conf 'active-dirs)))
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define no-limit-warning? #f) ; will be set to #t if no memory limits
-
-  (define current-timeout-control (make-parameter #f))
-  (provide timeout-control)
-  (define (timeout-control msg)
-    (log-line "timeout-control: ~s" msg)
-    ((current-timeout-control) msg))
-
-  (define (with-watcher w proc)
-    (let ([session-cust (make-custodian)]
-          [session-channel (make-channel)]
-          [timeout #f]
-          [status-box (box #f)])
-      (define (timeout-control msg)
-        (if (rational? msg)
-          (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
-          (case msg
-            [(reset) (timeout-control (get-conf 'session-timeout))]
-            [(disable) (set! timeout #f)]
-            [else (error 'timeout-control "bad argument: ~s" msg)])))
-      (current-timeout-control timeout-control)
-      (timeout-control 'reset)
-      (unless no-limit-warning?
-        (with-handlers ([exn:fail:unsupported?
-                         (lambda (x)
-                           (set! no-limit-warning? #t)
-                           (log-line "WARNING: per-session memory limit not supported by MrEd"))])
-          (custodian-limit-memory session-cust
-                                  (get-conf 'session-memory-limit)
-                                  session-cust)))
-      (let ([watcher
-             (parameterize ([current-custodian orig-custodian])
-               (thread
-                (lambda ()
-                  (let ([session-thread (channel-get session-channel)])
-                    (let loop ([timed-out? #f])
-                      (cond
-                        [(sync/timeout 3 session-thread)
-                         (let* ([status (unbox status-box)]
-                                [status (if status
-                                          (format " while ~a" status)
-                                          "")])
-                           (log-line "session killed ~a~a"
-                                     (if timed-out? "(timeout) " "(memory)")
-                                     status)
-                           (write+flush
-                            w (format "handin terminated due to ~a (program doesn't terminate?)~a"
-                                      (if timed-out? "time limit" "excessive memory use")
-                                      status))
-                           (close-output-port w)
-                           (channel-put session-channel 'done))]
-                        [(let ([t timeout]) ; grab value to avoid races
-                           (and t ((current-inexact-milliseconds) . > . t)))
-                         ;; Shutdown here to get the handin-terminated error
-                         ;;  message, instead of relying on a timeout at the
-                         ;;  run-server level
-                         (custodian-shutdown-all session-cust)
-                         (loop #t)]
-                        [else
-                         (collect-garbage)
-                         (log-line "running ~a ~a"
-                                   (current-memory-use session-cust)
-                                   (if no-limit-warning?
-                                     "(total)"
-                                     (list (current-memory-use orig-custodian)
-                                           (current-memory-use))))
-                         (loop #f)]))))))])
-        ;; Run proc in a thread under session-cust:
-        (let ([session-thread
-               (parameterize ([current-custodian session-cust]
-                              [current-run-status-box status-box])
-                 (thread
-                  (lambda ()
-                    (proc (lambda ()
-                            ;; Proc has succeeded...
-                            (parameterize ([current-custodian orig-custodian])
-                              (kill-thread watcher))))
-                    (channel-put session-channel 'done-normal))))])
-          (channel-put session-channel session-thread)
-          ;; Wait until the proc is done or killed (and kill is reported):
-          (channel-get session-channel)))))
-
-
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (log-line "server started ------------------------------")
-  (hook 'server-start `([port ,(get-conf 'port-number)]))
-
-  (define stop-status
-    (cond [(get-conf 'https-port-number) => serve-status]
-          [else void]))
-
-  (define session-count 0)
-
-  (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))])
-    (run-server
-     (get-conf 'port-number)
-     (lambda (r w)
-       (set! connection-num (add1 connection-num))
-       (when ((current-memory-use) . > . (get-conf 'session-memory-limit))
-         (collect-garbage))
-       (parameterize ([current-session
-                       (begin (set! session-count (add1 session-count))
-                              session-count)])
-         (let-values ([(here there) (ssl-addresses r)])
-           (log-line "connect from ~a" there)
-           (hook 'server-connect `([from ,there])))
-         (with-watcher
-          w
-          (lambda (kill-watcher)
-            (let ([r-safe (make-limited-input-port r 2048)])
-              (write+flush w 'handin)
-              ;; Check protocol:
-              (with-handlers ([exn:fail?
-                               (lambda (exn)
-                                 (let ([msg (if (exn? exn)
-                                              (exn-message exn)
-                                              (format "~e" exn))])
-                                   (kill-watcher)
-                                   (log-line "ERROR: ~a" msg)
-                                   (write+flush w msg)
-                                   ;; see note on close-output-port below
-                                   (close-output-port w)))])
-                (let ([protocol (read r-safe)])
-                  (if (eq? protocol 'ver1)
-                      (write+flush w 'ver1)
-                      (error 'handin "unknown protocol: ~s" protocol)))
-                (handle-connection r r-safe w)
-                (log-line "normal exit")
-                (kill-watcher)
-                ;; This close-output-port should not be necessary, and it's
-                ;; here due to a deficiency in the SSL binding.  The problem is
-                ;; that a custodian shutdown of w is harsher for SSL output
-                ;; than a normal close. A normal close flushes an internal
-                ;; buffer that's not supposed to exist, while the shutdown
-                ;; gives up immediately.
-                (close-output-port w)))))))
-     #f ; `with-watcher' handles our timeouts
-     (lambda (exn)
-       (printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
-     (lambda (port-k cnt reuse?)
-       (let ([l (ssl-listen port-k cnt #t)])
-         (ssl-load-certificate-chain! l "server-cert.pem")
-         (ssl-load-private-key! l "private-key.pem")
-         l))
-     ssl-close
-     ssl-accept
-     ssl-accept/enable-break)))
diff --git a/collects/handin-server/info.ss b/collects/handin-server/info.ss
index 11b5409196..a8d06ce502 100644
--- a/collects/handin-server/info.ss
+++ b/collects/handin-server/info.ss
@@ -1,5 +1,3 @@
 #lang setup/infotab
 
-(define name "The Handin-Server Collection")
-(define scribblings '(("scribblings/handin-server.scrbl" ())))
-
+(define scribblings '(("scribblings/handin-server.scrbl" (user-doc))))
diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss
new file mode 100644
index 0000000000..d50061d6eb
--- /dev/null
+++ b/collects/handin-server/main.ss
@@ -0,0 +1,691 @@
+#lang scheme/base
+(require mzlib/thread
+         scheme/port
+         openssl
+         scheme/file
+         "private/logger.ss"
+         "private/config.ss"
+         "private/lock.ss"
+         "private/md5.ss"
+         "private/run-status.ss"
+         "private/reloadable.ss"
+         "private/hooker.ss"
+         "web-status-server.ss"
+         ;; this sets some global parameter values, and this needs
+         ;; to be done in the main thread, rather than later in a
+         ;; user session thread (that will make the global changes
+         ;; not to be global.)
+         "sandbox.ss")
+
+(install-logger-port)
+
+;; errors to the user: no need for a "foo: " prefix
+(define (error* fmt . args)
+  (error (apply format fmt args)))
+
+(define (write+flush port . xs)
+  (for-each (lambda (x) (write x port) (newline port)) xs)
+  (flush-output port))
+
+(define-struct alist (name [l #:mutable]))
+(define (a-set! alist key val)
+  (let ([l (alist-l alist)])
+    (cond [(assq key l) => (lambda (p) (set-box! (cdr p) val))]
+          [else (set-alist-l! alist (cons (cons key (box val)) l))])))
+(define (a-ref alist key . default)
+  (cond [(assq key (alist-l alist)) => (lambda (x) (unbox (cdr x)))]
+        [(pair? default) (car default)]
+        [else (error (alist-name alist) "no value for `~s'" key)]))
+
+(define orig-custodian (current-custodian))
+
+;; On startup, check that the users file is not locked:
+(put-preferences null null
+  (lambda (f)
+    (delete-file f)
+    (put-preferences null null
+                     (lambda (f)
+                       (error 'handin-server
+                              "unable to clean up lock file: ~s" f))
+                     "users.ss"))
+  "users.ss")
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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 (get-conf 'max-upload-keep))
+        (begin (make-success-dir-available (add1 n))
+               (rename-file-or-directory name (success-dir (add1 n))))
+        (delete-directory/files name)))))
+
+(define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR)))
+(define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+"))))
+(define SUCCESS-GOOD (map success-dir '(0 1)))
+
+(define (cleanup-submission-body)
+  ;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it
+  ;; means that there was a failed submission and the next one will
+  ;; re-create ATTEMPT.
+  (let* ([dirlist (map path->string (directory-list))]
+         [dir (sort (filter (lambda (d)
+                              (and (directory-exists? d)
+                                   (regexp-match SUCCESS-RE d)))
+                            dirlist)
+                    string<?)]
+         [dir (and (pair? dir) (car dir))])
+    (when dir
+      (unless (member dir SUCCESS-GOOD)
+        (log-line "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
+                  (build-path (current-directory) dir)))
+      ;; We have a submission directory -- copy all newer things (extra
+      ;; things that exist in the main submission directory but not in
+      ;; SUCCESS, or things that are newer in the main submission
+      ;; directory are kept (but subdirs in SUCCESS will are copied as
+      ;; is))
+      (for-each
+       (lambda (f)
+         (define dir/f (build-path dir f))
+         (cond [(not (or (file-exists? f) (directory-exists? f)))
+                ;; f is in dir but not in the working directory
+                (copy-directory/files dir/f f)]
+               [(or (<= (file-or-directory-modify-seconds f)
+                        (file-or-directory-modify-seconds dir/f))
+                    (and (file-exists? f) (file-exists? dir/f)
+                         (not (= (file-size f) (file-size dir/f)))))
+                ;; f is newer in dir than in the working directory
+                (delete-directory/files f)
+                (copy-directory/files dir/f f)]))
+       (directory-list dir)))))
+
+(define cleanup-sema (make-semaphore 1))
+(define (cleanup-submission dir)
+  ;; This is called at a lock cleanup, so it is important that it does not
+  ;; throw an exception, or the whole server will be locked down.  It is
+  ;; invoked just before the lock is released, so fine to assume that we have
+  ;; exclusive access to the directory contents.
+  (with-handlers ([void
+                   (lambda (e)
+                     (log-line "*** ERROR DURING (cleanup-submission ~s) : ~a"
+                               dir (if (exn? e) (exn-message e) e)))])
+    (when (directory-exists? dir) ; submissions can fail before mkdir
+      (parameterize ([current-directory dir])
+        (call-with-semaphore cleanup-sema cleanup-submission-body)))))
+
+(define (cleanup-all-submissions)
+  (log-line "Cleaning up all submission directories")
+  (for-each (lambda (pset)
+              (when (directory-exists? pset) ; just in case
+                (parameterize ([current-directory pset])
+                  (for-each (lambda (sub)
+                              (when (directory-exists? sub) ; filter non-dirs
+                                (cleanup-submission sub)))
+                            (directory-list)))))
+            (get-conf 'all-dirs)))
+
+;; On startup, we scan all submissions, then repeat at random intervals (only
+;; if clients connected in that time), and check often for changes in the
+;; active/inactive directories and run a cleanup if there was a change
+(define connection-num 0)
+(void
+ (thread (lambda ()
+           (define last-all-dirs #f)
+           (define last-connection-num #f)
+           (let loop ()
+             (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
+               (when (>= n 0)
+                 (let ([new (get-conf 'all-dirs)])
+                   (if (equal? new last-all-dirs)
+                     (begin (sleep 30) (loop (sub1 n)))
+                     (begin (set! last-all-dirs new)
+                            (set! last-connection-num #f))))))
+             (unless (equal? last-connection-num connection-num)
+               (cleanup-all-submissions)
+               (set! last-connection-num connection-num))
+             (loop)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (save-submission s part)
+  (with-output-to-file part
+    (lambda () (display s))))
+
+(define (users->dirname users)
+  (apply string-append (car users)
+         (map (lambda (u) (string-append "+" u)) (cdr users))))
+
+(define (accept-specific-submission data r r-safe w)
+  ;; Note: users are always sorted
+  (define users       (a-ref data 'usernames))
+  (define assignments (a-ref data 'assignments))
+  (define assignment  (a-ref data 'assignment))
+  (define dirname     (users->dirname users))
+  (define len #f)
+  (unless (member assignment assignments)
+    (error* "not an active assignment: ~a" assignment))
+  (log-line "assignment for ~a: ~a" users assignment)
+  (hook 'submission-received `([usernames ,users] [assignment ,assignment]))
+  (write+flush w 'ok)
+  (set! len (read r-safe))
+  (unless (and (number? len) (integer? len) (positive? len))
+    (error* "bad length: ~s" len))
+  (unless (len . < . (get-conf 'max-upload))
+    (error* "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
+            (get-conf 'max-upload) len))
+  (parameterize ([current-directory (assignment<->dir assignment)])
+    (wait-for-lock dirname
+      (let ([dir (build-path (current-directory) dirname)])
+        (lambda () (cleanup-submission dir))))
+    (when (and (pair? users) (pair? (cdr users)))
+      ;; two or more users -- lock each one
+      (for-each wait-for-lock users))
+    (write+flush w 'go)
+    (unless (regexp-match #rx"[$]" r-safe)
+      (error* "did not find start-of-content marker"))
+    (let ([s (read-bytes len r)])
+      (unless (and (bytes? s) (= (bytes-length s) len))
+        (error* "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* "bad submission: ~a has an existing submission (~a)"
+                        d dir)))
+            (regexp-split #rx" *[+] *" (path->string dir))))
+         (directory-list))
+        (make-directory dirname))
+      (parameterize ([current-directory dirname]
+                     [current-messenger
+                      (case-lambda
+                        [(msg) (write+flush w 'message msg)]
+                        [(msg styles)
+                         (if (eq? 'final styles)
+                           (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))
+        (make-directory ATTEMPT-DIR)
+        (save-submission s (build-path ATTEMPT-DIR "handin"))
+        (timeout-control 'reset)
+        (log-line "checking ~a for ~a" assignment users)
+        (let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
+               [checker* (and (file-exists? checker*)
+                              (parameterize ([current-directory server-dir])
+                                (auto-reload-value
+                                 `(file ,(path->string checker*))
+                                 'checker)))])
+          (define-values (pre checker post)
+            (cond [(not checker*) (values #f #f #f)]
+                  [(procedure? checker*) (values #f checker* #f)]
+                  [(and (list? checker*) (= 3 (length checker*)))
+                   (apply values checker*)]
+                  [else (error* "bad checker value: ~e" checker*)]))
+          (when pre
+            (let ([dir (current-directory)])
+              (with-handlers
+                  ([void (lambda (e)
+                           (parameterize ([current-directory dir])
+                             (unless (ormap (lambda (d)
+                                              (and (directory-exists? d)
+                                                   (regexp-match
+                                                    SUCCESS-RE
+                                                    (path->string d))))
+                                            (directory-list))
+                               (parameterize ([current-directory ".."])
+                                 (when (directory-exists? dirname)
+                                   (delete-directory/files dirname)))))
+                           (raise e))])
+                (parameterize ([current-directory ATTEMPT-DIR])
+                  (pre users s)))))
+          (let ([part (if checker
+                        (parameterize ([current-directory ATTEMPT-DIR])
+                          (checker users s))
+                        (get-conf 'default-file-name))])
+            (write+flush w 'confirm)
+            (let ([v (read (make-limited-input-port r 50))])
+              (if (eq? v 'check)
+                (begin
+                  (log-line "saving ~a for ~a" assignment users)
+                  (parameterize ([current-directory ATTEMPT-DIR])
+                    (cond [part (unless (equal? part "handin")
+                                  (rename-file-or-directory "handin" part))]
+                          [(file-exists? "handin") (delete-file "handin")]))
+                  ;; 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))
+                  (hook 'submission-committed
+                        `([usernames ,users] [assignment ,assignment]))
+                  (when post
+                    (parameterize ([current-directory (success-dir 0)])
+                      (post users s))))
+                (error* "upload not confirmed: ~s" v)))))))))
+
+(define (retrieve-specific-submission data w)
+  ;; Note: users are always sorted
+  (define users       (a-ref data 'usernames))
+  (define assignments (a-ref data 'assignments))
+  (define assignment  (a-ref data 'assignment))
+  (define dirname     (users->dirname users))
+  (define submission-dir (build-path (assignment<->dir assignment) dirname))
+  (unless (member assignment assignments)
+    (error* "not an active assignment: ~a" assignment))
+  (unless (directory-exists? submission-dir)
+    (error* "no ~a submission directory for ~a" assignment users))
+  (log-line "retrieving assignment for ~a: ~a" users assignment)
+  (parameterize ([current-directory submission-dir])
+    (define magics '(#"WXME"
+                     #"<<<MULTI-SUBMISSION-FILE>>>"
+                     #"#reader(lib\"read.ss\"\"wxme\")WXME"))
+    (define mlen (apply max (map bytes-length magics)))
+    (define file
+      ;; find the newest wxme file
+      (let loop ([files (directory-list)] [file #f] [time #f])
+        (if (null? files)
+          file
+          (let ([f (car files)])
+            (if (and (file-exists? f)
+                     (let ([m (with-input-from-file f
+                                (lambda () (read-bytes mlen)))])
+                       (ormap (lambda (magic)
+                                (equal? magic
+                                        (subbytes m 0 (bytes-length magic))))
+                              magics))
+                     (or (not file)
+                         (> (file-or-directory-modify-seconds f) time)))
+              (loop (cdr files) f (file-or-directory-modify-seconds f))
+              (loop (cdr files) file time))))))
+    (if file
+      (let ([len (file-size file)])
+        (write+flush w len)
+        (display "$" w)
+        (display (with-input-from-file file (lambda () (read-bytes len))) w)
+        (flush-output w)
+        (hook 'submission-retrieved
+              `([usernames ,users] [assignment ,assignment])))
+      (error* "no ~a submission file found for ~a" assignment users))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (put-user-data username data)
+  ;; Although we don't have to worry about trashing the
+  ;;  prefs file, we do have to worry about a thread
+  ;;  getting killed while it locks the pref file.
+  ;; Avoid the problem by using orig-custodian.
+  (call-in-nested-thread
+   (lambda ()
+     (put-preferences
+      (list (string->symbol username)) (list data)
+      (lambda (f)
+        (error* "user database busy; please try again, and alert the adminstrator if problems persist"))
+      "users.ss"))
+   orig-custodian))
+
+(define (get-user-data username)
+  (get-preference (string->symbol username) (lambda () #f) #f "users.ss"))
+(define (check-field value field-re field-name field-desc)
+  (unless (cond [(or (string? field-re) (regexp? field-re))
+                 (regexp-match field-re value)]
+                [(list? field-re) (member value field-re)]
+                [(not field-re) #t]
+                [(eq? field-re '-) #t] ; -> hidden field, no check
+                [else (error* "bad spec: field-regexp is ~e" field-re)])
+    (error* "bad ~a: \"~a\"~a" field-name value
+            (if field-desc (format "; need ~a" field-desc) ""))))
+
+;; Utility for the next two functions: reconstruct a full list of
+;; extra-fields from user-fields, using "" for hidden fields
+(define (add-hidden-to-user-fields user-fields)
+  (let ([user-field-name->user-field
+         (map cons (get-conf 'user-fields) user-fields)])
+    (map (lambda (f)
+           (cond [(assq f user-field-name->user-field) => cdr]
+                 [else ""]))
+         (get-conf 'extra-fields))))
+
+(define (add-new-user data)
+  (define username     (a-ref data 'username/s))
+  (define passwd       (a-ref data 'password))
+  (define user-fields  (a-ref data 'user-fields))
+  (define extra-fields (add-hidden-to-user-fields user-fields))
+  (unless (get-conf 'allow-new-users)
+    (error* "new users not allowed: ~a" username))
+  (check-field username (get-conf 'user-regexp) "username"
+               (get-conf 'user-desc))
+  ;; Since we're going to use the username in paths, and + to split names:
+  (when (regexp-match #rx"[+/\\:|\"<>]" username)
+    (error* "username must not contain these characters: + / \\ : | \" < >"))
+  (when (regexp-match
+         #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
+         (string-foldcase username))
+    (error* "username must not be a Windows special file name"))
+  (when (regexp-match #rx"^[ .]|[ .]$" username)
+    (error* "username must not begin or end with a space or period"))
+  (when (regexp-match #rx"^solution" username)
+    (error* "the username prefix \"solution\" is reserved"))
+  (when (string=? "checker.ss" username)
+    (error* "the username \"checker.ss\" is reserved"))
+  (when (get-user-data username)
+    (error* "username already exists: `~a'" username))
+  (for-each (lambda (str info)
+              (check-field str (cadr info) (car info) (caddr info)))
+            extra-fields (get-conf 'extra-fields))
+  (wait-for-lock "+newuser+")
+  (log-line "create user: ~a" username)
+  (hook 'user-create `([username ,username] [fields ,extra-fields]))
+  (put-user-data username (cons passwd extra-fields)))
+
+(define (change-user-info data)
+  (define usernames    (a-ref data 'usernames))
+  (define user-datas   (a-ref data 'user-datas))
+  (define passwd       (a-ref data 'new-password))
+  (define user-fields  (a-ref data 'user-fields))
+  (define extra-fields (add-hidden-to-user-fields user-fields))
+  (unless (= 1 (length usernames))
+    (error* "cannot change a password for multiple users: ~a" usernames))
+  ;; the new data is the same as the old one for every empty string (includes
+  ;; hidden fields)
+  (let* ([username (car usernames)]
+         [old-data (car user-datas)]
+         [new-data (map (lambda (old new) (if (equal? "" new) old new))
+                        old-data (cons passwd extra-fields))])
+    (unless (or (get-conf 'allow-change-info)
+                (equal? (cdr new-data) (cdr old-data)))
+      (error* "changing information not allowed: ~a" username))
+    (when (equal? new-data old-data)
+      (error* "no fields changed: ~a" username))
+    (for-each (lambda (str info)
+                (check-field str (cadr info) (car info) (caddr info)))
+              (cdr new-data) (get-conf 'extra-fields))
+    (log-line "change info for ~a ~s -> ~s" username old-data new-data)
+    (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change
+      (hook 'user-change `([username ,username]
+                           [old ,(cdr old-data)]
+                           [new ,(cdr new-data)])))
+    (put-user-data username new-data)))
+
+(define (get-user-info data)
+  (define usernames  (a-ref data 'usernames))
+  (unless (= 1 (length usernames))
+    (error* "cannot get user-info for multiple users: ~a" usernames))
+  ;; filter out hidden fields
+  (let ([all-data (cdar (a-ref data 'user-datas))])
+    (filter values (map (lambda (d f)
+                          (and (memq f (get-conf 'user-fields)) d))
+                        all-data (get-conf 'extra-fields)))))
+
+(define crypt
+  (let ([c #f] [sema (make-semaphore 1)])
+    ;; use only when needed so it doesn't blow up on non-unix platforms
+    (lambda (passwd salt)
+      (unless c (set! c (dynamic-require '(lib "crypt.ss" "ffi") 'crypt)))
+      ;; crypt is not reentrant
+      (call-with-semaphore sema
+        (lambda () (bytes->string/utf-8 (c passwd salt)))))))
+(define (has-password? raw md5 passwords)
+  (define (good? passwd)
+    (define (bad-password msg)
+      (log-line "ERROR: ~a -- ~s" msg passwd)
+      (error* "bad password in user database"))
+    (cond [(string? passwd) (equal? md5 passwd)]
+          [(and (list? passwd) (= 2 (length passwd))
+                (symbol? (car passwd)) (string? (cadr passwd)))
+           (case (car passwd)
+             [(plaintext) (equal? raw (cadr passwd))]
+             [(unix)
+              (let ([salt (regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)"
+                                        (cadr passwd))])
+                (unless salt (bad-password "badly formatted unix password"))
+                (equal? (crypt raw (car salt)) (cadr passwd)))]
+             [else (bad-password "bad password type in user database")])]
+          [else (bad-password "bad password value in user database")]))
+  (or (member md5 passwords) ; very cheap search first
+      (ormap good? passwords)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (handle-connection r r-safe w)
+  (define msg #f)
+  (define active-assignments (assignment-list))
+  (define data
+    (make-alist 'protocol-data `((assignments . ,(box active-assignments)))))
+  (define (perror fmt . args) (apply error 'handin-protocol fmt args))
+  (let loop ()
+    (set! msg (read r-safe))
+    (case msg
+      ;; ----------------------------------------
+      ;; getting information from the client
+      [(set)
+       (let* ([key (read r-safe)] [val (read r-safe)])
+         (unless (symbol? key) (perror "bad key value: ~e" key))
+         (unless (if (eq? 'user-fields key)
+                   (and (list? val)
+                        (- (length val) (length (get-conf 'user-fields)))
+                        (andmap string? val))
+                   (string? val))
+           (perror "bad value for set: ~e" val))
+         (when (a-ref data key #f) (perror "multiple values for ~e" key))
+         (case key
+           [(username/s)
+            (unless (get-conf 'username-case-sensitive)
+              (set! val (string-foldcase val)))
+            (let ([usernames
+                   ;; Username lists must always be sorted, and never empty
+                   ;; (regexp-split will not return an empty list)
+                   (sort (regexp-split #rx" *[+] *" val) string<?)])
+              (a-set! data 'usernames usernames)
+              (a-set! data 'user-datas (map get-user-data usernames)))]
+           [(password new-password)
+            ;; empty passwords are left empty for change-user-info to re-use
+            ;; an existing password value
+            (when (eq? key 'password) (a-set! data 'raw-password val))
+            (unless (equal? "" val) (set! val (md5 val)))]
+           [(usernames user-datas raw-password assignments)
+            ;; forbid setting these directly
+            (perror "bad key for `set': ~e" key)])
+         (a-set! data key val))
+       (loop)]
+      ;; ----------------------------------------
+      ;; sending information to the client
+      [(get-active-assignments)
+       (write+flush w active-assignments)
+       (loop)]
+      [(get-user-fields)
+       (write+flush w (map car (get-conf 'user-fields)))
+       (loop)]
+      ;; ----------------------------------------
+      ;; action handlers
+      ;; (don't loop back except get-user-info which needs authorization)
+      [(create-user) (add-new-user data)]
+      [(bye) #t] ; <- general disconnection
+      ;; other messages require a login: valid users and a good password
+      [else
+       (when (eof-object? msg)
+         (let ([username/s (a-ref data 'username/s #f)])
+           (apply error 'handin
+                  (if username/s `("hangup (~a)" ,username/s) `("hangup")))))
+       (let ([usernames  (a-ref data 'usernames #f)]
+             [user-datas (a-ref data 'user-datas #f)])
+         (when (or (memq #f user-datas)
+                   (not (has-password?
+                         (a-ref data 'raw-password)
+                         (a-ref data 'password)
+                         (cons (get-conf 'master-password)
+                               (map car user-datas)))))
+           (log-line "failed login: ~a" (a-ref data 'username/s))
+           (error* "bad username or password for ~a"
+                   (a-ref data 'username/s)))
+         (log-line "login: ~a" usernames)
+         (hook 'login `([usernames ,usernames])))
+       (case msg
+         [(change-user-info) (change-user-info data)]
+         [(save-submission) (accept-specific-submission data r r-safe w)]
+         [(get-submission) (retrieve-specific-submission data w)]
+         [(get-user-info) (write+flush w (get-user-info data)) (loop)]
+         [else (perror "bad message `~a'" msg)])]))
+  (write+flush w 'ok)) ; final confirmation for *all* actions
+
+(define (assignment-list)
+  (map assignment<->dir (get-conf 'active-dirs)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define no-limit-warning? #f) ; will be set to #t if no memory limits
+
+(define current-timeout-control (make-parameter #f))
+(provide timeout-control)
+(define (timeout-control msg)
+  (log-line "timeout-control: ~s" msg)
+  ((current-timeout-control) msg))
+
+(define (with-watcher w proc)
+  (let ([session-cust (make-custodian)]
+        [session-channel (make-channel)]
+        [timeout #f]
+        [status-box (box #f)])
+    (define (timeout-control msg)
+      (if (rational? msg)
+        (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
+        (case msg
+          [(reset) (timeout-control (get-conf 'session-timeout))]
+          [(disable) (set! timeout #f)]
+          [else (error 'timeout-control "bad argument: ~s" msg)])))
+    (current-timeout-control timeout-control)
+    (timeout-control 'reset)
+    (unless no-limit-warning?
+      (with-handlers ([exn:fail:unsupported?
+                       (lambda (x)
+                         (set! no-limit-warning? #t)
+                         (log-line "WARNING: per-session memory limit not supported by MrEd"))])
+        (custodian-limit-memory session-cust
+                                (get-conf 'session-memory-limit)
+                                session-cust)))
+    (let ([watcher
+           (parameterize ([current-custodian orig-custodian])
+             (thread
+              (lambda ()
+                (let ([session-thread (channel-get session-channel)])
+                  (let loop ([timed-out? #f])
+                    (cond
+                      [(sync/timeout 3 session-thread)
+                       (let* ([status (unbox status-box)]
+                              [status (if status
+                                        (format " while ~a" status)
+                                        "")])
+                         (log-line "session killed ~a~a"
+                                   (if timed-out? "(timeout) " "(memory)")
+                                   status)
+                         (write+flush
+                          w (format "handin terminated due to ~a (program doesn't terminate?)~a"
+                                    (if timed-out? "time limit" "excessive memory use")
+                                    status))
+                         (close-output-port w)
+                         (channel-put session-channel 'done))]
+                      [(let ([t timeout]) ; grab value to avoid races
+                         (and t ((current-inexact-milliseconds) . > . t)))
+                       ;; Shutdown here to get the handin-terminated error
+                       ;;  message, instead of relying on a timeout at the
+                       ;;  run-server level
+                       (custodian-shutdown-all session-cust)
+                       (loop #t)]
+                      [else
+                       (collect-garbage)
+                       (log-line "running ~a ~a"
+                                 (current-memory-use session-cust)
+                                 (if no-limit-warning?
+                                   "(total)"
+                                   (list (current-memory-use orig-custodian)
+                                         (current-memory-use))))
+                       (loop #f)]))))))])
+      ;; Run proc in a thread under session-cust:
+      (let ([session-thread
+             (parameterize ([current-custodian session-cust]
+                            [current-run-status-box status-box])
+               (thread
+                (lambda ()
+                  (proc (lambda ()
+                          ;; Proc has succeeded...
+                          (parameterize ([current-custodian orig-custodian])
+                            (kill-thread watcher))))
+                  (channel-put session-channel 'done-normal))))])
+        (channel-put session-channel session-thread)
+        ;; Wait until the proc is done or killed (and kill is reported):
+        (channel-get session-channel)))))
+
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(log-line "server started ------------------------------")
+(hook 'server-start `([port ,(get-conf 'port-number)]))
+
+(define stop-status
+  (cond [(get-conf 'https-port-number) => serve-status]
+        [else void]))
+
+(define session-count 0)
+
+(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))])
+  (run-server
+   (get-conf 'port-number)
+   (lambda (r w)
+     (set! connection-num (add1 connection-num))
+     (when ((current-memory-use) . > . (get-conf 'session-memory-limit))
+       (collect-garbage))
+     (parameterize ([current-session
+                     (begin (set! session-count (add1 session-count))
+                            session-count)])
+       (let-values ([(here there) (ssl-addresses r)])
+         (log-line "connect from ~a" there)
+         (hook 'server-connect `([from ,there])))
+       (with-watcher
+        w
+        (lambda (kill-watcher)
+          (let ([r-safe (make-limited-input-port r 2048)])
+            (write+flush w 'handin)
+            ;; Check protocol:
+            (with-handlers ([exn:fail?
+                             (lambda (exn)
+                               (let ([msg (if (exn? exn)
+                                            (exn-message exn)
+                                            (format "~e" exn))])
+                                 (kill-watcher)
+                                 (log-line "ERROR: ~a" msg)
+                                 (write+flush w msg)
+                                 ;; see note on close-output-port below
+                                 (close-output-port w)))])
+              (let ([protocol (read r-safe)])
+                (if (eq? protocol 'ver1)
+                  (write+flush w 'ver1)
+                  (error 'handin "unknown protocol: ~s" protocol)))
+              (handle-connection r r-safe w)
+              (log-line "normal exit")
+              (kill-watcher)
+              ;; This close-output-port should not be necessary, and it's
+              ;; here due to a deficiency in the SSL binding.  The problem is
+              ;; that a custodian shutdown of w is harsher for SSL output
+              ;; than a normal close. A normal close flushes an internal
+              ;; buffer that's not supposed to exist, while the shutdown
+              ;; gives up immediately.
+              (close-output-port w)))))))
+   #f ; `with-watcher' handles our timeouts
+   (lambda (exn)
+     (printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
+   (lambda (port-k cnt reuse?)
+     (let ([l (ssl-listen port-k cnt #t)])
+       (ssl-load-certificate-chain! l "server-cert.pem")
+       (ssl-load-private-key! l "private-key.pem")
+       l))
+   ssl-close
+   ssl-accept
+   ssl-accept/enable-break))
diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss
index cd35861bdf..3ddb7db87f 100644
--- a/collects/handin-server/web-status-server.ss
+++ b/collects/handin-server/web-status-server.ss
@@ -1,83 +1,82 @@
-(module web-status-server mzscheme
-  (require (lib "unit.ss")
-           (lib "ssl-tcp-unit.ss" "net")
-           (lib "tcp-sig.ss" "net")
-           (lib "tcp-unit.ss" "net")
-           (lib "file.ss")
-           (lib "etc.ss")
-           (lib "web-server-unit.ss" "web-server")
-           (lib "web-server-sig.ss" "web-server")
-           (lib "web-config-sig.ss" "web-server")
-           (lib "web-config-unit.ss" "web-server")
-           (lib "namespace.ss" "web-server" "configuration")
-           "private/config.ss")
+#lang scheme/base
+(require scheme/unit
+         net/ssl-tcp-unit
+         net/tcp-sig
+         net/tcp-unit
+         (only-in mzlib/etc this-expression-source-directory)
+         web-server/web-server-unit
+         web-server/web-server-sig
+         web-server/web-config-sig
+         web-server/web-config-unit
+         web-server/configuration/namespace
+         "private/config.ss")
 
-  (provide serve-status)
+(provide serve-status)
 
-  (define (serve-status port-no)
+(define (serve-status port-no)
 
-    (define web-dir
-      (path->string
-       (or (get-conf 'web-base-dir)
-           (build-path (this-expression-source-directory) "status-web-root"))))
+  (define web-dir
+    (path->string
+     (or (get-conf 'web-base-dir)
+         (build-path (this-expression-source-directory) "status-web-root"))))
 
-    (define config
-      `((port ,port-no)
-        (max-waiting 40)
-        (initial-connection-timeout 30)
-        (default-host-table
-          (host-table
-           (default-indices "index.html")
-           (log-format parenthesized-default)
-           (messages
-            (servlet-message "servlet-error.html")
-            (authentication-message "forbidden.html")
-            (servlets-refreshed "servlet-refresh.html")
-            (passwords-refreshed "passwords-refresh.html")
-            (file-not-found-message "not-found.html")
-            (protocol-message "protocol-error.html")
-            (collect-garbage "collect-garbage.html"))
-           (timeouts
-            (default-servlet-timeout 120)
-            (password-connection-timeout 300)
-            (servlet-connection-timeout 86400)
-            (file-per-byte-connection-timeout 1/20)
-            (file-base-connection-timeout 30))
-           (paths
-            (configuration-root "conf")
-            (host-root ,web-dir)
-            (log-file-path ,(cond [(get-conf 'web-log-file) => path->string]
-                                  [else #f]))
-            (file-root "htdocs")
-            (servlet-root ,web-dir)
-            (mime-types ,(path->string
-                          (build-path (collection-path "web-server")
-                                      "default-web-root"
-                                      "mime.types")))
-            (password-authentication "unused"))))
-        (virtual-host-table)))
+  (define config
+    `((port ,port-no)
+      (max-waiting 40)
+      (initial-connection-timeout 30)
+      (default-host-table
+        (host-table
+         (default-indices "index.html")
+         (log-format parenthesized-default)
+         (messages
+          (servlet-message "servlet-error.html")
+          (authentication-message "forbidden.html")
+          (servlets-refreshed "servlet-refresh.html")
+          (passwords-refreshed "passwords-refresh.html")
+          (file-not-found-message "not-found.html")
+          (protocol-message "protocol-error.html")
+          (collect-garbage "collect-garbage.html"))
+         (timeouts
+          (default-servlet-timeout 120)
+          (password-connection-timeout 300)
+          (servlet-connection-timeout 86400)
+          (file-per-byte-connection-timeout 1/20)
+          (file-base-connection-timeout 30))
+         (paths
+          (configuration-root "conf")
+          (host-root ,web-dir)
+          (log-file-path ,(cond [(get-conf 'web-log-file) => path->string]
+                                [else #f]))
+          (file-root "htdocs")
+          (servlet-root ,web-dir)
+          (mime-types ,(path->string
+                        (build-path (collection-path "web-server")
+                                    "default-web-root"
+                                    "mime.types")))
+          (password-authentication "unused"))))
+      (virtual-host-table)))
 
-    (define configuration
-      (configuration-table-sexpr->web-config@
-       config
-       #:web-server-root web-dir
-       #:make-servlet-namespace
-       (make-make-servlet-namespace
-        #:to-be-copied-module-specs
-        '((lib "md5.ss"    "handin-server" "private")
-          (lib "logger.ss" "handin-server" "private")
-          (lib "config.ss" "handin-server" "private")
-          (lib "hooker.ss" "handin-server" "private")
-          (lib "reloadable.ss" "handin-server" "private")))))
+  (define configuration
+    (configuration-table-sexpr->web-config@
+     config
+     #:web-server-root web-dir
+     #:make-servlet-namespace
+     (make-make-servlet-namespace
+      #:to-be-copied-module-specs
+      '(handin-server/private/md5
+        handin-server/private/logger
+        handin-server/private/config
+        handin-server/private/hooker
+        handin-server/private/reloadable))))
 
-    (define-unit-binding config@ configuration (import) (export web-config^))
-    (define-unit-binding ssl-tcp@
-      (make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f)
-      (import) (export tcp^))
-    (define-compound-unit/infer status-server@
-      (import)
-      (link ssl-tcp@ config@ web-server@)
-      (export web-server^))
-    (define-values/invoke-unit/infer status-server@)
+  (define-unit-binding config@ configuration (import) (export web-config^))
+  (define-unit-binding ssl-tcp@
+    (make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f)
+    (import) (export tcp^))
+  (define-compound-unit/infer status-server@
+    (import)
+    (link ssl-tcp@ config@ web-server@)
+    (export web-server^))
+  (define-values/invoke-unit/infer status-server@)
 
-    (serve)))
+  (serve))