From 00f2c671a3c5f00b5e2ca5c7518880de3947642f Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 30 Apr 2007 17:51:11 +0000
Subject: [PATCH] Removing unit servlets

svn: r6101
---
 .../Defaults/documentation/examples/add.ss    |   24 +-
 .../Defaults/documentation/examples/count.ss  |   28 +-
 .../Defaults/documentation/examples/hello.ss  |   16 +-
 .../documentation/servlet-examples.html       |   31 +-
 .../Defaults/documentation/servlet.html       |   91 +-
 .../default-web-root/servlets/configure.ss    |    7 +-
 .../default-web-root/servlets/examples/add.ss |   26 +-
 .../servlets/examples/compound/add.ss         |   24 +-
 .../servlets/examples/compound/helper-sig.ss  |    5 -
 .../servlets/examples/compound/helper.ss      |   15 +-
 .../servlets/examples/compound/multiply.ss    |  169 +-
 .../servlets/examples/count.ss                |   18 +-
 .../default-web-root/servlets/examples/dir.ss |   24 +-
 .../servlets/examples/hello.ss                |   21 +-
 .../servlets/examples/quiz.ss                 |  381 ++--
 .../servlets/tests/bad-return.ss              |   12 +-
 .../default-web-root/servlets/tests/broken.ss |   12 +-
 .../servlets/tests/incremental.ss             |   29 +-
 .../default-web-root/servlets/tests/mime.ss   |   17 +-
 .../servlets/tests/new-suite/bad-xexpr.ss     |   10 +
 .../servlets/tests/new-suite/bus-error.ss     |   14 +
 .../servlets/tests/new-suite/button.ss        |    9 +
 .../servlets/tests/new-suite/cell-example.ss  |    1 +
 .../servlets/tests/new-suite/counter-cells.ss |   46 +
 .../servlets/tests/new-suite/counter-cps.ss   |   36 +
 .../servlets/tests/new-suite/counter.ss       |   35 +
 .../servlets/tests/new-suite/cust.ss          |   16 +
 .../servlets/tests/new-suite/expiration.ss    |   36 +
 .../servlets/tests/new-suite/fault.ss         |   12 +
 .../servlets/tests/new-suite/form.ss          |   28 +
 .../servlets/tests/new-suite/fupload.ss       |   24 +
 .../servlets/tests/new-suite/hang.ss          |   15 +
 .../servlets/tests/new-suite/hod-0618.ss      |   19 +
 .../servlets/tests/new-suite/inf-essence.ss   |   13 +
 .../servlets/tests/new-suite/inf.ss           |   12 +
 .../tests/new-suite/instance-expiration-2.ss  |   24 +
 .../tests/new-suite/instance-expiration.ss    |   23 +
 .../tests/new-suite/jas01-fix-param.ss        |   11 +
 .../servlets/tests/new-suite/jas01-fix.ss     |   14 +
 .../servlets/tests/new-suite/jas01-param.ss   |    9 +
 .../servlets/tests/new-suite/jas01-test.ss    |   10 +
 .../servlets/tests/new-suite/jas01.ss         |   14 +
 .../servlets/tests/new-suite/lock.ss          |   24 +
 .../servlets/tests/new-suite/none-test.ss     |   10 +
 .../servlets/tests/new-suite/plus.ss          |   28 +
 .../servlets/tests/new-suite/pr5490.ss        |    8 +
 .../servlets/tests/new-suite/pr5565.ss        |   19 +
 .../servlets/tests/new-suite/pr7359.ss        |   12 +
 .../servlets/tests/new-suite/pr7533.ss        |   19 +
 .../servlets/tests/new-suite/pr7935-other.ss  |   10 +
 .../servlets/tests/new-suite/ssd.ss           |   18 +
 .../servlets/tests/new-suite/static.ss        |    9 +
 .../servlets/tests/new-suite/update.ss        |   11 +
 .../servlets/tests/new-suite/utf8.ss          |   17 +
 .../default-web-root/servlets/tests/size.ss   |   34 +-
 .../default-web-root/servlets/tests/test.ss   |   16 +-
 .../default-web-root/servlets/tests/url.ss    |   17 +-
 .../dispatchers/dispatch-servlets.ss          |   22 +-
 collects/web-server/private/configure.ss      | 1554 ++++++++---------
 collects/web-server/sig.ss                    |    8 +-
 60 files changed, 1916 insertions(+), 1301 deletions(-)
 delete mode 100644 collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/bad-xexpr.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/bus-error.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/button.ss
 create mode 120000 collects/web-server/default-web-root/servlets/tests/new-suite/cell-example.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/counter-cells.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/counter-cps.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/counter.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/cust.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/expiration.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/fault.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/form.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/fupload.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/hang.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/hod-0618.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/inf-essence.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/inf.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration-2.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix-param.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01-param.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01-test.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/lock.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/none-test.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/plus.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr5490.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr7359.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr7533.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/ssd.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/static.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/update.ss
 create mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/utf8.ss

diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
index 18bd5902d6..7fc173d7ba 100644
--- a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
@@ -1,9 +1,8 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "date.ss"))
-
-(unit (import servlet^)
-      (export)
+(module add mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
   
   ; request-number : str -> num
   (define (request-number which-number)
@@ -22,9 +21,10 @@
                          (input ([type "text"] [name "number"] [value ""]))
                          (input ([type "submit"] [name "enter"] [value "Enter"])))))))
   
-  (send/suspend
-   (lambda (k-url)
-     `(html (head (title "Sum"))
-            (body ([bgcolor "white"])
-                  (p "The sum is "
-                     ,(number->string (+ (request-number "first") (request-number "second")))))))))
\ No newline at end of file
+  (define (start initial-request)
+    (send/suspend
+     (lambda (k-url)
+       `(html (head (title "Sum"))
+              (body ([bgcolor "white"])
+                    (p "The sum is "
+                       ,(number->string (+ (request-number "first") (request-number "second"))))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
index caaa76bd7c..916799f5ba 100644
--- a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
@@ -1,15 +1,15 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "date.ss"))
-
-(let ([count 0]
-      [date (date->string (seconds->date (current-seconds)) 'time-too)])
-  (unit (import servlet^)
-        (export)
+(module count mzscheme
+  (require (lib "date.ss"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define count 0)
+  (define a-date (date->string (seconds->date (current-seconds)) 'time-too))
+  (define (start initial-request)
+    (set! count (add1 count))
     
-  (set! count (add1 count))
-    
-  `(html (head (title "Counter"))
-         (body ([bgcolor "white"])
-               (p "This servlet was called " ,(number->string count)
-                  " times since loaded on " ,date ".")))))
\ No newline at end of file
+    `(html (head (title "Counter"))
+           (body ([bgcolor "white"])
+                 (p "This servlet was called " ,(number->string count)
+                    " times since loaded on " ,a-date ".")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
index 49379267e8..07149a4495 100644
--- a/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
@@ -1,11 +1,11 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-
-(unit (import servlet^)
-      (export)
+(module hello mzscheme
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
   
   (define the-text "Hello, Web!")
   
-  `(html (head (title ,the-text))
-         (body ([bgcolor "white"])
-               (p ,the-text))))
\ No newline at end of file
+  (define (start initial-request)
+    `(html (head (title ,the-text))
+           (body ([bgcolor "white"])
+                 (p ,the-text)))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
index 1aab0d245c..63d2d7850d 100644
--- a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
@@ -1 +1,30 @@
-<html><head><title>PLT Servlet Examples</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Servlet Examples</h2><p>The table below links to small example servlets.<br />The configuration tool is a larger example.<br />The `go' links only work when served from the PLT Web server.</p><table><tr><th>Source Code</th><th>Evaluate</th></tr><tr><td><a href="examples/add.ss">add.ss</a></td><td><a href="/servlets/examples/add.ss">go</a></td></tr><tr><td><a href="examples/count.ss">count.ss</a></td><td><a href="/servlets/examples/count.ss">go</a></td></tr><tr><td><a href="examples/hello.ss">hello.ss</a></td><td><a href="/servlets/examples/hello.ss">go</a></td></tr></table><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
\ No newline at end of file
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>PLT Servlet Examples</title>
+</head>
+<body bgcolor="white">
+<img src="/Defaults/documentation/web-server.gif" width="61" height="57"><h2>PLT Servlet Examples</h2>
+<p>The table below links to small example servlets.<br>The configuration tool is a larger example.<br>The `go' links only work when served from the PLT Web server.</p>
+<table>
+<tr>
+<th>Source Code</th>
+<th>Evaluate</th>
+</tr>
+<tr>
+<td><a href="examples/add.ss">add.ss</a></td>
+<td><a href="/servlets/examples/add.ss">go</a></td>
+</tr>
+<tr>
+<td><a href="examples/count.ss">count.ss</a></td>
+<td><a href="/servlets/examples/count.ss">go</a></td>
+</tr>
+<tr>
+<td><a href="examples/hello.ss">hello.ss</a></td>
+<td><a href="/servlets/examples/hello.ss">go</a></td>
+</tr>
+</table>
+<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif"></a></p>
+</body>
+</html>
diff --git a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
index fefb5404fd..e0275d4012 100644
--- a/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
+++ b/collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
@@ -1,34 +1,63 @@
-<html><head><title>PLT Web Server: Servlet Interface</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Web Server: Servlet Interface</h2><p>Instead of serving files from a special directory verbatim, the Web server executes the contained Scheme code and serves the output.  By default, the special directory  is named "servlets" within the "default-web-root" of the "web-server" collection directory.  Each file in that directory must evaluate to a servlet.
-A servlet is a <code>unit/sig</code> that imports the <code>servlet^</code>
-signature and exports nothing.  (Search in <code>help-desk</code> for more information on <code>unit/sig</code> and on signatures.)  To construct a <code>unit/sig</code> with the appropriate imports, the servlet must require the two modules providing<code>unit/sig</code>s and the <code>servlet^</code> signature:</p><blockquote><code><pre>
-(require (lib "unitsig.ss")
-         (lib "servlet-sig.ss" "web-server"))
-(unit/sig ()
-  (import servlet^)
-</pre>&nbsp;&nbsp;...insert servlet code here...<code>)</code></code></blockquote><p>The last value in the <code>unit/sig</code> must be a <em>response</em> to an HTTP request.</p><p>A <code>Response</code> is one of the following:
-</p><ul><li>an <code>X-expression</code> representing HTML <br />
-    (Search for XML in <code>help-desk</code>.)</li><li>a <code>(listof string)</code> where
-<ul><li>The first string is the mime type (often "text/html", but see <a href="http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc2822.html">RFC 2822</a> for other options).The rest of the strings provide the document's content.</li></ul></li><li><code>(make-response/full</code> code message seconds mime extras body<code>)</code> where 
-<ul><li>code is a natural number indicating the HTTP response code</li><li>message is a string describing the code to a human</li><li>seconds is a natural number indicating the time the resource was
-    created.  Use (current-seconds) for dynamically created responses.</li><li>mime is a string indicating the response type.</li><li>extras is a <code>(listof (cons symbol string))</code> containing extra headers for redirects, authentication, or cookies.</li><li>body is a <code>(listof string)</code></li></ul></li></ul><p>Evaluating <code>(require (lib "servlet-sig.ss" "web-server"))</code> loads
-the <code>servlet^</code> signature consisting of the following imports:</p><ul><li>initial-request : <code>request</code>, where a request is <br /><code>(make-request method uri headers bindings host-ip client-ip)</code>, where
-<ul><li> method : <code>(Union 'get 'post)</code></li><li> uri : <code>URL</code> <br />
-  see the <code>net</code> collection in <code>help-desk</code> for details</li><li> headers : <code>(listof (cons symbol string))</code> <br />
-  optional HTTP headers for this request</li><li> bindings : <code>(listof (cons symbol string))</code> <br />
-  name value pairs from the form submitted or the query part of the URL.</li></ul></li></ul><p>The <code>path</code> part of the URL suplies the file path to the servlet relative to the "servlets" directory.  However, paths may also contain extra path components that servlets may use as additional input.  For example all of the following URLs refer to the same servlet: <ul><li><code>http://www.plt-scheme.org/servlets/my-servlet</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra/directories</code></li></ul></p><p>The above imports support handling a single input from a Web form. To ease the development of more interactive servlets, the <code>servlet^</code> signature also provides the following functions:
-</p><ul><li><code>send/suspend : (str -&gt; Response) -&gt; request</code></li></ul>The argument, a function that consumes a string, is given a <code>URL</code> that can be used in the document.  The argument function must produce a
-  response corresponding to the document's body.  Requests to the
-  given <code>URL</code> resume the computation at the point
-  <code>send/suspend</code> was invoked.  Thus, the argument function normally
-  produces an HTML form with the "action" attribute set to the provided
-  <code>URL</code>.  The result of <code>send/suspend</code> represents the
-  next request.
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
+<html>
+    <head>
+	<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
+	<title>PLT Web Server: Servlet Interface</title>
+    </head>
+    <body bgcolor="white">
+	<img src="/Defaults/documentation/web-server.gif" width="61" height="57" />
+	<h2>PLT Web Server: Servlet Interface</h2>
+	<p>Instead of serving files from a special directory
+	    verbatim, the Web server executes the contained
+	    Scheme code and serves the output.  By default,
+	    the special directory is named "servlets" within
+	    the "default-web-root" of the "web-server"
+	    collection directory.  Each file in that directory
+	    must evaluate to a servlet.</p>
 
-<ul><li><code>send/finish : Response -&gt;</code> doesn't return <br />This provides a convenient way to report an error or otherwise produce a final response.  Once called, all URLs generated by send/suspend become invalid.  Calling send/finish allows the system to reclaim resources consumed by the servlet.</li><li><code>adjust-timeout! : Nat -&gt; Void</code><br />
- The server will shutdown each instance of a servlet after an unspecified default amount of time since the last time that servlet instance handled a request.  Calling adjust-timeout! allows programmers to choose this number of seconds.  Larger numbers consume more resources
-  while smaller numbers force servlet users to restart computations more often.
-</li></ul><p>The <code>servlet-helpers</code> module, required with <blockquote><code>(require (lib "servlet-helpers.ss" "web-server"))</code></blockquote> provides a few additional functions helpful for constructing servlets: <ul><li><code>extract-binding/single : sym (listof (cons sym str)) -&gt; str</code>This extracts a single value associated with sym in the form bindings. If multiple or zero values are associated with the name, it raises an exception.</li><li>extract-bindings : sym (listof (cons sym str)) -&gt; (listof str)returns a list of values assocaited with the name sym.</li><li><code>extract-user-pass : (listof (cons sym str)) -&gt; (U #f (cons str str))</code><br /><code>(define (extract-user-pass headers) ...)</code>Servlets may easily implement password based authentication by extracting password information from the HTTP headers.  The return value is either a pair consisting of the username and password from the headers or #f if no password was provided.</li></ul></p><h3>Special URLs</h3><p>The Web server caches passwords and servlets for performance reasons. Requesting the URL<blockquote><a href="/conf/refresh-passwords"><code>http://my-host/conf/refresh-passwords</code></a></blockquote>reloads the password file.  After updating a servlet, loading the URL <blockquote><a href="/conf/refresh-servlets"><code>http://my-host/conf/refresh-servlets</code></a></blockquote>causes the server to reload each servlet on the next invocation. This loses any per-servlet state (not per servlet instance state) computed before the unit invocation.</p>
+	<p>A servlet is a <code>module</code> that provides
+	    three values: an
+	    <code>interface-version</code>,
+	    a <code>timeout</code>, and a
+	    <code>start</code> procedure:</p>
+	<blockquote><code><pre>
+	    (module servlet mzscheme
+	    (require (lib "servlet.ss" "web-server"))
+	    (provide interface-version timeout start)
+	    (define interface-version 'v1)
+	    (define timeout +inf.0)
+	    (define (start initial-request)
+	    ...))
+	    </pre></code></blockquote>
 
-<p>The Web server's garbage collect may be invoked at the URL: <blockquote><a href="/conf/collect-garbage"><code>http://my-host/conf/collect-garbage</code></a></blockquote></p>
+	<p>The <code>start</code> procedure should produce a
+	    a <em>response</em> to an HTTP request. Please
+	    refer to the documentation available via the Help
+	    Desk for more information about working with these
+	    values and programming servlets.</p>
 
-<p><a href="servlet-examples.html">Examples of Servlets</a></p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html>
+	<h3>Special URLs</h3>
+	<p>The Web server caches passwords and servlets for
+	    performance reasons. Requesting the URL</p>
+	<blockquote><a
+			href="/conf/refresh-passwords"><code>http://my-host/conf/refresh-passwords</code></a></blockquote>
+	<p>reloads the password file.  After updating a
+	    servlet, loading the
+	    URL</p>
+	<blockquote><a
+			href="/conf/refresh-servlets"><code>http://my-host/conf/refresh-servlets</code></a></blockquote>
+	<p>causes the server to reload each servlet on the
+	    next invocation. This loses any per-servlet state (not
+	    per servlet instance state) computed before the unit
+	    invocation.</p>
+
+	<p>The Web server's garbage collect may be invoked at
+	    the URL: </p>
+	<blockquote><a href="/conf/collect-garbage"><code>http://my-host/conf/collect-garbage</code></a></blockquote>
+
+	<p><a href="servlet-examples.html">Examples of Servlets</a></p>
+	<p>Powered by <a href="http://www.plt-scheme.org/">
+	    <img width="53" height="19"
+	    src="/Defaults/documentation/plt-logo.gif" /></a></p>
+    </body>
+</html>
diff --git a/collects/web-server/default-web-root/servlets/configure.ss b/collects/web-server/default-web-root/servlets/configure.ss
index e489783136..0dcab3cafe 100644
--- a/collects/web-server/default-web-root/servlets/configure.ss
+++ b/collects/web-server/default-web-root/servlets/configure.ss
@@ -2,7 +2,6 @@
 ; unless you never want to reconfigure the Web server again.
 ; The servlet accepts requests only from the *same machine* as the Web server
 ; for security purposes.
-
-(require (lib "configure.ss" "web-server" "private"))
-
-servlet
+(module configure mzscheme
+  (require (lib "configure.ss" "web-server" "private"))
+  (provide (all-from (lib "configure.ss" "web-server" "private"))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/add.ss b/collects/web-server/default-web-root/servlets/examples/add.ss
index 6019484e1e..739d9836e6 100644
--- a/collects/web-server/default-web-root/servlets/examples/add.ss
+++ b/collects/web-server/default-web-root/servlets/examples/add.ss
@@ -1,17 +1,16 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "date.ss"))
-
-(unit (import servlet^)
-      (export)
-
+(module add mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
   ; request-number : str -> num
   (define (request-number which-number)
     (string->number
      (extract-binding/single
       'number
       (request-bindings (send/suspend (build-request-page which-number))))))
-
+  
   ; build-request-page : str -> str -> response
   (define (build-request-page which-number)
     (lambda (k-url)
@@ -21,8 +20,9 @@
                          "Enter the " ,which-number " number to add: "
                          (input ([type "text"] [name "number"] [value ""]))
                          (input ([type "submit"] [name "enter"] [value "Enter"])))))))
-
-  `(html (head (title "Sum"))
-         (body ([bgcolor "white"])
-               (p "The sum is "
-                  ,(number->string (+ (request-number "first") (request-number "second")))))))
+  
+  (define (start initial-request)
+    `(html (head (title "Sum"))
+           (body ([bgcolor "white"])
+                 (p "The sum is "
+                    ,(number->string (+ (request-number "first") (request-number "second"))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/add.ss b/collects/web-server/default-web-root/servlets/examples/compound/add.ss
index c33d6cd4f4..fb8d215f0b 100644
--- a/collects/web-server/default-web-root/servlets/examples/compound/add.ss
+++ b/collects/web-server/default-web-root/servlets/examples/compound/add.ss
@@ -1,20 +1,12 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         "helper-sig.ss")
-
-(define main@
-  (unit
-    (import servlet^ my-servlet-helpers^)
-    (export)
-    
+(module add mzscheme
+  (require "helper.ss")
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
     `(html (head (title "Sum"))
            (body ([bgcolor "white"])
                  (p "The sum is "
                     ,(number->string (+ (get-number "the first number to add")
-                                        (get-number "the second number to add"))))))))
-
-(compound-unit (import (S : servlet^))
-               (export)
-               (link 
-                (((H : my-servlet-helpers^)) ((load-relative "helper.ss") S))
-                (() main@ S H)))
+                                        (get-number "the second number to add"))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss
deleted file mode 100644
index 03197cff4d..0000000000
--- a/collects/web-server/default-web-root/servlets/examples/compound/helper-sig.ss
+++ /dev/null
@@ -1,5 +0,0 @@
-(module helper-sig mzscheme
-  (provide my-servlet-helpers^)
-  (require (lib "unit.ss"))
-  
-  (define-signature my-servlet-helpers^ (get-number)))
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
index 75c19b7170..da23b180b1 100644
--- a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
+++ b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
@@ -1,11 +1,6 @@
-(require (lib "xml.ss" "xml")
-         (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         "helper-sig.ss")
-
-(unit 
-  (import servlet^)
-  (export my-servlet-helpers^)
+(module helper mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
   
   ; get-number : string -> number
   ; to prompt the user for a number
@@ -20,7 +15,7 @@
                    (build-suspender
                     (list prompt)
                     `(,@error-message
-                      (p ,prompt (input ([type "text"] [name "n"])))
-                      (input ([type "submit"] [value "Okay"]))))))))]
+                        (p ,prompt (input ([type "text"] [name "n"])))
+                        (input ([type "submit"] [value "Okay"]))))))))]
              [n (string->number n-str)])
         (or n (ask `((p (font ([color "red"]) ,n-str) " is not a number.  Please enter a number."))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
index aa15c649bd..01881d92fd 100644
--- a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
+++ b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
@@ -1,94 +1,87 @@
-(require (lib "servlet-sig.ss" "web-server")
-         (lib "unit.ss")
-         (lib "etc.ss")
-         "helper-sig.ss")
-
-(define multiply@
-  (unit
-    (import servlet^ my-servlet-helpers^)
-    (export)
-    
-    ; matrix = (listof (listof num))
-    
-    ; matrix-multiply : matrix matrix -> matrix
-    (define (matrix-multiply a b)
-      (map (lambda (a-row)
-             (side-map (lambda (b-column)
-                         (apply + (map * a-row b-column)))
-                       b))
-           a))
-    
-    ; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b)
-    (define (side-map f m)
-      (cond
-        [(null? (car m)) null]
-        [else (cons (f (map car m))
-                    (side-map f (map cdr m)))]))
-    
-    ; ---
-    
-    ; get-dimentions : -> nat nat
-    ; to ask for and return the number of rows and columns
-    (define (get-dimentions)
-      (values
-       (get-number "the number of rows in the first matrix")
-       (get-number "the number of rows in the second matrix")))
-    
-    ; get-matrix : nat nat -> matrix
-    (define (get-matrix rows columns)
-      (let ([b (get-matrix-bindings rows columns)])
-        (build-list
-         rows
-         (lambda (r)
-           (build-list
-            columns
-            (lambda (c)
-              (string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
-    
-    ; get-matrix-bindings : nat nat -> (listof (cons sym str))
-    (define (get-matrix-bindings rows columns)
-      (request-bindings
-       (send/suspend
-        (build-suspender
-         (list "Enter a " (number->string rows) " by "
-               (number->string columns) " Matrix")
-         `((table
-            . ,(build-list
-                rows
-                (lambda (r)
-                  `(tr . ,(build-list
-                           columns
-                           (lambda (c)
-                             `(td (input ([type "text"] [name ,(field-name r c)])))))))))
-           (input ([type "submit"] [name "submit"] [value "Okay"])))))))
-    
-    ; field-name : nat nat -> str
-    (define (field-name row column)
-      (format "x-~a-~a" row column))
-    
-    ; ---
-    
-    ; render-matrix : matrix -> html
-    (define (render-matrix m)
-      `(table
-        ([border "1"])
-        . ,(map (lambda (row)
-                  `(tr . ,(map (lambda (n)
-                                 `(td ,(number->string n)))
-                               row)))
-                m)))
-    
-    ; main
+(module multiply mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "etc.ss")
+           "helper.ss")
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  ; matrix = (listof (listof num))
+  
+  ; matrix-multiply : matrix matrix -> matrix
+  (define (matrix-multiply a b)
+    (map (lambda (a-row)
+           (side-map (lambda (b-column)
+                       (apply + (map * a-row b-column)))
+                     b))
+         a))
+  
+  ; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b)
+  (define (side-map f m)
+    (cond
+      [(null? (car m)) null]
+      [else (cons (f (map car m))
+                  (side-map f (map cdr m)))]))
+  
+  ; ---
+  
+  ; get-dimentions : -> nat nat
+  ; to ask for and return the number of rows and columns
+  (define (get-dimentions)
+    (values
+     (get-number "the number of rows in the first matrix")
+     (get-number "the number of rows in the second matrix")))
+  
+  ; get-matrix : nat nat -> matrix
+  (define (get-matrix rows columns)
+    (let ([b (get-matrix-bindings rows columns)])
+      (build-list
+       rows
+       (lambda (r)
+         (build-list
+          columns
+          (lambda (c)
+            (string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
+  
+  ; get-matrix-bindings : nat nat -> (listof (cons sym str))
+  (define (get-matrix-bindings rows columns)
+    (request-bindings
+     (send/suspend
+      (build-suspender
+       (list "Enter a " (number->string rows) " by "
+             (number->string columns) " Matrix")
+       `((table
+          . ,(build-list
+              rows
+              (lambda (r)
+                `(tr . ,(build-list
+                         columns
+                         (lambda (c)
+                           `(td (input ([type "text"] [name ,(field-name r c)])))))))))
+         (input ([type "submit"] [name "submit"] [value "Okay"])))))))
+  
+  ; field-name : nat nat -> str
+  (define (field-name row column)
+    (format "x-~a-~a" row column))
+  
+  ; ---
+  
+  ; render-matrix : matrix -> html
+  (define (render-matrix m)
+    `(table
+      ([border "1"])
+      . ,(map (lambda (row)
+                `(tr . ,(map (lambda (n)
+                               `(td ,(number->string n)))
+                             row)))
+              m)))
+  
+  ; main
+  (define (start initial-request)
     `(html (head (title "Matrix Product"))
            (body
             (p "The matrix product is"
                ,(render-matrix
                  (let-values ([(r c) (get-dimentions)])
                    (matrix-multiply (get-matrix r c)
-                                    (get-matrix c r)))))))))
-
-(compound-unit (import (S : servlet^))
-               (export)
-               (link 
-                (((H : my-servlet-helpers^)) ((load-relative "helper.ss") S))
-                (() multiply@ S H)))
\ No newline at end of file
+                                    (get-matrix c r)))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/count.ss b/collects/web-server/default-web-root/servlets/examples/count.ss
index 61a3a7bbfa..6cd826b97b 100644
--- a/collects/web-server/default-web-root/servlets/examples/count.ss
+++ b/collects/web-server/default-web-root/servlets/examples/count.ss
@@ -1,11 +1,11 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "date.ss"))
-
-(let ([count 0]
-      [date (date->string (seconds->date (current-seconds)) 'time-too)])
-  (unit (import servlet^)
-        (export)
+(module count mzscheme
+  (require (lib "date.ss"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define count 0)
+  (define a-date (date->string (seconds->date (current-seconds)) 'time-too))
+  (define (start initial-request)
     (define other-count 0)
     
     (set! other-count (add1 other-count))
@@ -15,4 +15,4 @@
            (body ([bgcolor "white"])
                  (p "This servlet was called " ,(number->string count)
                     " times and " ,(number->string other-count)
-                    " times since loaded on " ,date ".")))))
\ No newline at end of file
+                    " times since loaded on " ,a-date ".")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/dir.ss b/collects/web-server/default-web-root/servlets/examples/dir.ss
index c8e138f817..5715869e21 100644
--- a/collects/web-server/default-web-root/servlets/examples/dir.ss
+++ b/collects/web-server/default-web-root/servlets/examples/dir.ss
@@ -1,13 +1,11 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "date.ss"))
-
-(unit (import servlet^)
-      (export)
-
-  (send/back
-   `(html (head (title "Current Directory Page"))
-          (body
-           (h1 "Current Directory Page")
-           (p "The current directory is: " (em ,(path->string (current-directory))))))))
-
+(module dir mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    (send/back
+     `(html (head (title "Current Directory Page"))
+            (body
+             (h1 "Current Directory Page")
+             (p "The current directory is: " (em ,(path->string (current-directory)))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/hello.ss b/collects/web-server/default-web-root/servlets/examples/hello.ss
index 49379267e8..a8606770bd 100644
--- a/collects/web-server/default-web-root/servlets/examples/hello.ss
+++ b/collects/web-server/default-web-root/servlets/examples/hello.ss
@@ -1,11 +1,10 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-
-(unit (import servlet^)
-      (export)
-  
-  (define the-text "Hello, Web!")
-  
-  `(html (head (title ,the-text))
-         (body ([bgcolor "white"])
-               (p ,the-text))))
\ No newline at end of file
+(module hello mzscheme
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    (define the-text "Hello, Web!")
+    
+    `(html (head (title ,the-text))
+           (body ([bgcolor "white"])
+                 (p ,the-text)))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/quiz.ss b/collects/web-server/default-web-root/servlets/examples/quiz.ss
index 7dc0d33ba4..83607f77a8 100644
--- a/collects/web-server/default-web-root/servlets/examples/quiz.ss
+++ b/collects/web-server/default-web-root/servlets/examples/quiz.ss
@@ -11,198 +11,195 @@
 ;; choices = (listof string), possible answers to the question
 ;; correct-answer = integer, index into choices
 ;;
-
-;; Configuration
-(define *data-file*
-  (build-path (collection-path "web-server")
-              "default-web-root" "servlets" "examples" "english-measure-questions.ss"))
-(define *questions-per-quiz* 5)
-
-
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "list.ss")
-         (lib "etc.ss"))
-
-(unit (import servlet^)
-      (export)
-
- ;; Accessors into question sexp's
- (define question-text car)
- (define question-choices cadr)
- (define question-answer caddr)
- (define question-explanation cadddr)
-
- (define quiz (load *data-file*))
- (define quiz-intro (car quiz))
- (define all-questions (cadr quiz))
-
- ;; ask-question: question number number -> (listof (cons symbol string))
- ;; Page for asking quiz question.
- ;; result contains a binding for 'answer
- (define (ask-question question-sexp question-number n-questions)
-   (request-bindings
+(module quiz mzscheme
+  ;; Configuration
+  (define *data-file*
+    (build-path (collection-path "web-server")
+                "default-web-root" "servlets" "examples" "english-measure-questions.ss"))
+  (define *questions-per-quiz* 5)
+  
+  (require (lib "servlet.ss" "web-server")
+           (lib "list.ss")
+           (lib "etc.ss"))
+  
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  ;; Accessors into question sexp's
+  (define question-text car)
+  (define question-choices cadr)
+  (define question-answer caddr)
+  (define question-explanation cadddr)
+  
+  (define quiz (load *data-file*))
+  (define quiz-intro (car quiz))
+  (define all-questions (cadr quiz))
+  
+  ;; ask-question: question number number -> (listof (cons symbol string))
+  ;; Page for asking quiz question.
+  ;; result contains a binding for 'answer
+  (define (ask-question question-sexp question-number n-questions)
+    (request-bindings
+     (send/suspend
+      (lambda (k-url)
+        (let ((answer-num -1))
+          `(html
+            (head
+             (title "Quiz Servlet")
+             (body
+              (p ,(format "Question ~A of ~A" (add1 question-number)
+                          n-questions))
+              (p ,(question-text question-sexp))
+              (form ((method "post") (action ,k-url))
+                    ,@(map (lambda (choice)
+                             (set! answer-num (add1 answer-num))
+                             `(p
+                               ,(choice-descriptor answer-num) ". "
+                               (input ((type "radio")
+                                       (name "answer")
+                                       (value ,(number->string
+                                                answer-num))))
+                               ,choice))
+                           (cadr question-sexp))
+                    (input ((type "submit")
+                            (value "Next"))))))))))))
+  
+  ;; ((listof question-sexp) size) -> (listof question-sexp)
+  ;; Choose a subset (without duplicates) of given size from a given list
+  ;; assume subset-size <= (length questions)
+  (define (random-question-set questions subset-size)
+    (let choose-questions ([questions questions]
+                           [chosen '()])
+      (if (= (length chosen) subset-size)
+          chosen
+          (let ([qstn (list-ref questions (random (length questions)))])
+            (choose-questions
+             (filter
+              (lambda (q)
+                (not (eq? qstn q)))
+              questions)
+             (cons qstn chosen))))))
+  
+  ;; choice-descriptor: number -> character
+  ;; Map 0 to "A", 1 to "B", etc
+  (define (choice-descriptor number)
+    (string (integer->char (+ (char->integer #\A) number))))
+  
+  ;; begin-quiz: -> request
+  ;; request bindings are not currently used
+  (define (begin-quiz)
     (send/suspend
      (lambda (k-url)
-       (let ((answer-num -1))
-         `(html
-           (head
-            (title "Quiz Servlet")
-            (body
-             (p ,(format "Question ~A of ~A" (add1 question-number)
-                         n-questions))
-             (p ,(question-text question-sexp))
-             (form ((method "post") (action ,k-url))
-                   ,@(map (lambda (choice)
-                            (set! answer-num (add1 answer-num))
-                            `(p
-                              ,(choice-descriptor answer-num) ". "
-                              (input ((type "radio")
-                                      (name "answer")
-                                      (value ,(number->string
-                                               answer-num))))
-                              ,choice))
-                          (cadr question-sexp))
-                   (input ((type "submit")
-                           (value "Next"))))))))))))
-
- ;; ((listof question-sexp) size) -> (listof question-sexp)
- ;; Choose a subset (without duplicates) of given size from a given list
- ;; assume subset-size <= (length questions)
- (define (random-question-set questions subset-size)
-   (let choose-questions ([questions questions]
-                          [chosen '()])
-     (if (= (length chosen) subset-size)
-       chosen
-       (let ([qstn (list-ref questions (random (length questions)))])
-         (choose-questions
-          (filter
-           (lambda (q)
-             (not (eq? qstn q)))
-           questions)
-          (cons qstn chosen))))))
-
- ;; choice-descriptor: number -> character
- ;; Map 0 to "A", 1 to "B", etc
- (define (choice-descriptor number)
-   (string (integer->char (+ (char->integer #\A) number))))
-
- ;; begin-quiz: -> request
- ;; request bindings are not currently used
- (define (begin-quiz)
-   (send/suspend
-    (lambda (k-url)
-      `(html
-        (head
-         (title "Quiz Servlet"))
-        (body
-         (p ,quiz-intro)
-         (form ((method "post") (action ,k-url))
-               (input ((type "submit")
-                       (value "Begin Quiz")))))))))
-
- ;; Compare list of questions to answers.
- ;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
- (define (score-quiz questions answers)
-   (foldr
-    (lambda (question answer csw)
-      (let ([correct-answer (question-answer question)])
-        (apply
-         (lambda (correct skipped wrong)
-           (cond
-            [(not answer)
-             (list correct (add1 skipped) wrong)]
-            [(= answer correct-answer)
-             (list (add1 correct) skipped wrong)]
-            [else
-             (list correct skipped (add1 wrong))]))
-         csw)))
-    (list 0 0 0) questions answers))
-
- ;; end-quiz: (listof question) (listof (or/c number false)) -> request
- ;; request bindings are not currently used.
- (define (end-quiz questions answers)
-   (send/forward
-    (lambda (k-url)
-      (let* ((score (score-quiz questions answers))
-             (correct (car score))
-             (skipped (cadr score))
-             (wrong (caddr score))
-             (xml
-              `(html
-                (head
-                 (title "Quiz Servlet"))
-                (body
-                 (p ,(format "Your score: ~A/~A"
-                             correct
-                             (+ correct wrong skipped)))
-                 (p ,(format "Correct: ~A" correct))
-                 (p ,(format "Skipped: ~A" skipped))
-                 (p ,(format "Wrong: ~A" wrong))
-                 (table ((border "5"))
-                        (tr (td "Question") (td "Correct Answer")
-                            (td "Your Answer") (td "Explanation"))
-                        ,@(map
-                           (lambda (q a)
-                             `(tr
-                               (td ,(question-text q))
-                               (td ,(format "~A. ~A"
-                                            (choice-descriptor
-                                             (question-answer q))
-                                            (list-ref (question-choices q)
-                                                      (question-answer q))))
-                               (td ,(if a
-                                      (format "~A. ~A" (choice-descriptor a)
-                                              (list-ref
-                                               (question-choices q) a))
-                                      "Skipped"))
-                               (td ,(question-explanation q))))
-                           questions answers))
-                 (form ((method "get")
-                        (action ,k-url))
-                       (input ((type "submit")
-                               (value "New Quiz"))))))))
-        xml))))
-
- ;; Return the first value for key in bindings, if it at least one
- ;; exists, otherwise #f.
- (define (binding-value key bindings)
-   (and (exists-binding? key bindings)
-        (extract-binding/single key bindings)))
-
- ;; run-quiz: -> void
- ;; run quizes until the student gets tired
- (define (run-quiz)
-   (let ([*questions-per-quiz*
-          (if (> *questions-per-quiz* (length all-questions))
-            (begin
-              (display (format "~A ~A ~A ~A\n"
-                               "Configuration error.  *questions-per-quiz*:"
-                               *questions-per-quiz*
-                               "for a question list of size"
-                               (length all-questions)))
-              (length all-questions))
-            *questions-per-quiz*)])
-
-     (let ([questions (random-question-set all-questions
-                                           *questions-per-quiz*)])
-       (begin-quiz)
-       (let ([answers
-              (build-list (length questions)
-                          (lambda (question-number)
-                            (let ([answer
-                                   (binding-value 'answer
-                                                  (ask-question
-                                                   (list-ref questions question-number)
-                                                   question-number
-                                                   *questions-per-quiz*))])
-                              (and answer (string->number answer)))))])
-         (end-quiz questions answers))))
-   (run-quiz))
-
- ;; Entry point into servlet.
- (run-quiz)
-
- )
-
+       `(html
+         (head
+          (title "Quiz Servlet"))
+         (body
+          (p ,quiz-intro)
+          (form ((method "post") (action ,k-url))
+                (input ((type "submit")
+                        (value "Begin Quiz")))))))))
+  
+  ;; Compare list of questions to answers.
+  ;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
+  (define (score-quiz questions answers)
+    (foldr
+     (lambda (question answer csw)
+       (let ([correct-answer (question-answer question)])
+         (apply
+          (lambda (correct skipped wrong)
+            (cond
+              [(not answer)
+               (list correct (add1 skipped) wrong)]
+              [(= answer correct-answer)
+               (list (add1 correct) skipped wrong)]
+              [else
+               (list correct skipped (add1 wrong))]))
+          csw)))
+     (list 0 0 0) questions answers))
+  
+  ;; end-quiz: (listof question) (listof (or/c number false)) -> request
+  ;; request bindings are not currently used.
+  (define (end-quiz questions answers)
+    (send/forward
+     (lambda (k-url)
+       (let* ((score (score-quiz questions answers))
+              (correct (car score))
+              (skipped (cadr score))
+              (wrong (caddr score))
+              (xml
+               `(html
+                 (head
+                  (title "Quiz Servlet"))
+                 (body
+                  (p ,(format "Your score: ~A/~A"
+                              correct
+                              (+ correct wrong skipped)))
+                  (p ,(format "Correct: ~A" correct))
+                  (p ,(format "Skipped: ~A" skipped))
+                  (p ,(format "Wrong: ~A" wrong))
+                  (table ((border "5"))
+                         (tr (td "Question") (td "Correct Answer")
+                             (td "Your Answer") (td "Explanation"))
+                         ,@(map
+                            (lambda (q a)
+                              `(tr
+                                (td ,(question-text q))
+                                (td ,(format "~A. ~A"
+                                             (choice-descriptor
+                                              (question-answer q))
+                                             (list-ref (question-choices q)
+                                                       (question-answer q))))
+                                (td ,(if a
+                                         (format "~A. ~A" (choice-descriptor a)
+                                                 (list-ref
+                                                  (question-choices q) a))
+                                         "Skipped"))
+                                (td ,(question-explanation q))))
+                            questions answers))
+                  (form ((method "get")
+                         (action ,k-url))
+                        (input ((type "submit")
+                                (value "New Quiz"))))))))
+         xml))))
+  
+  ;; Return the first value for key in bindings, if it at least one
+  ;; exists, otherwise #f.
+  (define (binding-value key bindings)
+    (and (exists-binding? key bindings)
+         (extract-binding/single key bindings)))
+  
+  ;; run-quiz: -> void
+  ;; run quizes until the student gets tired
+  (define (run-quiz)
+    (let ([*questions-per-quiz*
+           (if (> *questions-per-quiz* (length all-questions))
+               (begin
+                 (display (format "~A ~A ~A ~A\n"
+                                  "Configuration error.  *questions-per-quiz*:"
+                                  *questions-per-quiz*
+                                  "for a question list of size"
+                                  (length all-questions)))
+                 (length all-questions))
+               *questions-per-quiz*)])
+      
+      (let ([questions (random-question-set all-questions
+                                            *questions-per-quiz*)])
+        (begin-quiz)
+        (let ([answers
+               (build-list (length questions)
+                           (lambda (question-number)
+                             (let ([answer
+                                    (binding-value 'answer
+                                                   (ask-question
+                                                    (list-ref questions question-number)
+                                                    question-number
+                                                    *questions-per-quiz*))])
+                               (and answer (string->number answer)))))])
+          (end-quiz questions answers))))
+    (run-quiz))
+  
+  ;; Entry point into servlet.
+  (define (start initial-request)
+    (run-quiz)))
 
diff --git a/collects/web-server/default-web-root/servlets/tests/bad-return.ss b/collects/web-server/default-web-root/servlets/tests/bad-return.ss
index c06e71f001..d3f950c84f 100644
--- a/collects/web-server/default-web-root/servlets/tests/bad-return.ss
+++ b/collects/web-server/default-web-root/servlets/tests/bad-return.ss
@@ -1,6 +1,6 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-(unit
-  (import servlet^)
-  (export)
-  5)
+(module bad-return mzscheme
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    5))
diff --git a/collects/web-server/default-web-root/servlets/tests/broken.ss b/collects/web-server/default-web-root/servlets/tests/broken.ss
index cf90fcbdf4..342979f19f 100644
--- a/collects/web-server/default-web-root/servlets/tests/broken.ss
+++ b/collects/web-server/default-web-root/servlets/tests/broken.ss
@@ -1,6 +1,6 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-(unit
-  (import servlet^)
-  (export)
-  (raise 'kablooie))
+(module broken mzscheme
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    (raise 'kablooie)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/incremental.ss b/collects/web-server/default-web-root/servlets/tests/incremental.ss
index 6532956676..cf1ececed2 100644
--- a/collects/web-server/default-web-root/servlets/tests/incremental.ss
+++ b/collects/web-server/default-web-root/servlets/tests/incremental.ss
@@ -1,15 +1,14 @@
-(require (lib "servlet-sig.ss" "web-server")
-         (lib "unit.ss"))
-
-(unit
-  (import servlet^)
-  (export)
-  
-  (send/finish
-   (make-html-response/incremental
-    (lambda (output-chunk)
-      (output-chunk "<html><head><title>"
-                    "my-title</title></head>\n")
-      (output-chunk "<body><p>The first paragraph</p>\n")
-      (sleep 4)
-      (output-chunk "<p>The second paragraph</p></body></html>\n")))))
+(module incremental mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    (send/finish
+     (make-html-response/incremental
+      (lambda (output-chunk)
+        (output-chunk "<html><head><title>"
+                      "my-title</title></head>\n")
+        (output-chunk "<body><p>The first paragraph</p>\n")
+        (sleep 4)
+        (output-chunk "<p>The second paragraph</p></body></html>\n"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/mime.ss b/collects/web-server/default-web-root/servlets/tests/mime.ss
index d9302ba450..2dea2d3620 100644
--- a/collects/web-server/default-web-root/servlets/tests/mime.ss
+++ b/collects/web-server/default-web-root/servlets/tests/mime.ss
@@ -1,8 +1,9 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-(unit
-  (import servlet^)
-  (export)
-  `("text/uber-format"
-    "uber uber uber"
-    "-de-doo"))
+(module mime mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    `("text/uber-format"
+      "uber uber uber"
+      "-de-doo")))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/bad-xexpr.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/bad-xexpr.ss
new file mode 100644
index 0000000000..6d7d17c43d
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/bad-xexpr.ss
@@ -0,0 +1,10 @@
+(module bad-xexpr mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start initial-request)
+    (send/back
+     `(html (a ([href url])
+               "Title")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/bus-error.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/bus-error.ss
new file mode 100644
index 0000000000..e5a329ba90
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/bus-error.ss
@@ -0,0 +1,14 @@
+(module bus-error mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 120)
+  
+  (define (end request)
+    `(html (body "End")))
+  
+  (define (start request)
+    (send/suspend/callback
+     `(html (body (p (a ([href ,start]) "Forward"))
+                  (p (a ([href ,end]) "End")))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/button.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/button.ss
new file mode 100644
index 0000000000..da50c14af1
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/button.ss
@@ -0,0 +1,9 @@
+(module button mzscheme
+ (require (lib "mred.ss" "mred")
+          (lib "class.ss"))
+ (provide interface-version timeout start)
+ (define interface-version 'v1)
+ (define timeout +inf.0)
+ (define (start initial-request)
+   (let ([b (new button% (label "Button"))])
+   (list #"text/plain" "Button"))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/cell-example.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/cell-example.ss
new file mode 120000
index 0000000000..114adb316f
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/cell-example.ss
@@ -0,0 +1 @@
+/Users/jay/Development/Projects/papers/web-cells/cell-example.ss
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cells.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cells.ss
new file mode 100644
index 0000000000..0e8650818f
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cells.ss
@@ -0,0 +1,46 @@
+(module counter-cells mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start _)
+    (main-page))
+  
+  (define the-counter (make-web-cell:local 0))
+  (define the-header (make-web-cell:local (box "Main page")))
+  
+  (define (counter)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 ,(number->string (web-cell:local-ref the-counter)))
+              (a ([href ,(embed/url
+                          (lambda _
+                            (web-cell:local-mask the-counter 
+                                                 (add1 (web-cell:local-ref the-counter)))
+                            (counter)))])
+                 "Increment")
+              (br)
+              (a ([href ,(embed/url
+                          (lambda _
+                            'exit))])
+                 "Exit")))))
+  
+  (define (main-page)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 ,(unbox (web-cell:local-ref the-header)))
+              (form ([method "POST"]
+                     [action ,(embed/url
+                               (lambda (req)
+                                 (set-box! (web-cell:local-ref the-header)
+                                           (extract-binding/single 'header (request-bindings req)))
+                                 (main-page)))])
+                    (input ([type "text"] [name "header"]))
+                    (input ([type "submit"])))
+              (br)
+              (a ([href ,(embed/url
+                          (lambda _
+                            (counter)
+                            (main-page)))])
+                 "View Counter"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cps.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cps.ss
new file mode 100644
index 0000000000..6b8aaf4653
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/counter-cps.ss
@@ -0,0 +1,36 @@
+(module counter-cps mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start _)
+    (main-page))
+  
+  (define the-counter (make-parameter 0))
+  
+  (define (counter k)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 ,(number->string (the-counter)))
+              (a ([href ,(embed/url
+                          (lambda _
+                            (parameterize ([the-counter (add1 (the-counter))])
+                              (counter k))))])
+                 "Increment")
+              (br)
+              (a ([href ,(embed/url
+                          (lambda _
+                            (k 'exit)))])
+                 "Exit")))))
+  
+  (define (main-page)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 "Main page")
+              (a ([href ,(embed/url
+                          (lambda _
+                            (counter
+                             (lambda (v)
+                               (main-page)))))])
+                 "View Counter"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/counter.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/counter.ss
new file mode 100644
index 0000000000..fccaf10462
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/counter.ss
@@ -0,0 +1,35 @@
+(module counter mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start _)
+    (main-page))
+  
+  (define the-counter (make-parameter 0))
+  
+  (define (counter)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 ,(number->string (the-counter)))
+              (a ([href ,(embed/url
+                          (lambda _
+                            (parameterize ([the-counter (add1 (the-counter))])
+                              (counter))))])
+                 "Increment")
+              (br)
+              (a ([href ,(embed/url
+                          (lambda _
+                            'exit))])
+                 "Exit")))))
+  
+  (define (main-page)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (h2 "Main page")
+              (a ([href ,(embed/url
+                          (lambda _
+                            (counter)
+                            (main-page)))])
+                 "View Counter"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/cust.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/cust.ss
new file mode 100644
index 0000000000..c8f34fe2d0
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/cust.ss
@@ -0,0 +1,16 @@
+(module cust mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define servlet-cust (current-custodian))
+  (define timeout 30)
+  (define interface-version 'v1)
+  
+  (define (start ir)
+    `(html
+      (head (title "Custodian test"))
+      (body 
+       (p ,(if (eq? (current-custodian) servlet-cust)
+               "It didn't work."
+               "It did work."))))))
+    
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/expiration.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/expiration.ss
new file mode 100644
index 0000000000..b6cec86438
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/expiration.ss
@@ -0,0 +1,36 @@
+(module expiration mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define timeout (* 60 3))
+  (define interface-version 'v1)
+  
+  (define (start initial-request)
+    (parameterize ([current-servlet-continuation-expiration-handler
+                    (lambda (request-for-expired)
+                      (send/back
+                       `(html (body (p "You lose! (Default)")))))])
+      (let loop ([request initial-request])
+        (send/suspend/dispatch
+         (lambda (embed/url)
+           `(html
+             (head (title "Expiration demo"))
+             (body (p "Open each of the links below in a new window. Then click the link in 'Forget' window. Then reload each window.")
+                   (p (a ([href ,(embed/url loop)])
+                         "Loop"))
+                   (p (a ([href ,(embed/url 
+                                  loop
+                                  (lambda (request-for-expired)
+                                    (send/back
+                                     `(html (head (title "Expiration demo"))
+                                            (body (p "You win! (Special)"))))))])
+                         "Loop w/ Expiration"))
+                   (p (a ([href ,(embed/url
+                                  (lambda (request)
+                                    (loop 
+                                     (send/forward
+                                      (lambda (k-url)
+                                        `(html (head (title "Expiration demo"))
+                                               (body (p (a ([href ,k-url]) "Forget the past.")))))))))])
+                         "Prepare to forget the past."))))))))))
+                                     
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/fault.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/fault.ss
new file mode 100644
index 0000000000..9986d1abd6
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/fault.ss
@@ -0,0 +1,12 @@
+(module fault mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout 30)
+  (define X 0)
+  (define (start request)
+    (send/suspend
+     (lambda (k-url)
+       `(a ([href ,k-url]) "Click")))
+    (set! X (add1 X))
+    (format "~a" "fault")))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/form.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/form.ss
new file mode 100644
index 0000000000..c9c4da17ea
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/form.ss
@@ -0,0 +1,28 @@
+(module form mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "pretty.ss"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start _)
+    (define req
+      (send/suspend
+       (lambda (k-url)
+         `(html 
+           (body
+            (form ([action ,k-url] [method "POST"])
+                  (input ([type "checkbox"] [name "checkbox"]))
+                  (input ([type "text"] [name "text"]))
+                  (input ([type "submit"] [name "submit"]))))))))
+    (define binds
+      (request-bindings req))
+    (define sport
+      (open-output-string))
+    (define pp
+      (parameterize ([current-output-port sport])
+        (pretty-print binds)))
+    `(html
+      (body
+       (pre
+        ,(get-output-string sport))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/fupload.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/fupload.ss
new file mode 100644
index 0000000000..50225836c8
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/fupload.ss
@@ -0,0 +1,24 @@
+(module fupload mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "plt-match.ss"))
+  (provide (all-defined))
+  
+  (define timeout 60)
+  (define interface-version 'v1)
+  (define (start initial-request)
+    (send/suspend/callback
+     `(html (head)
+            (body
+             (form ([action
+                     ,(lambda (request)
+                        (define b (request-bindings/raw request))
+                        (match (bindings-assq #"file" b)
+                          [(struct binding:file (_ filename _))
+                           `(html 
+                             (body
+                              ,(bytes->string/utf-8 filename)))]))]
+                    [method "post"]
+                    [enctype "multipart/form-data"])
+                   (h3 "Submit for an Assignment")
+                   (input ([name "file"] [type "file"] [size "30"]))
+                   (input ([type "submit"] [value "Submit"]))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/hang.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/hang.ss
new file mode 100644
index 0000000000..01b89deaf0
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/hang.ss
@@ -0,0 +1,15 @@
+(module hang mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  
+  (define (start initial-request)
+    (send/suspend
+     (lambda (k-url)
+       `(html (a ([href ,k-url]) "Next"))))
+    (send/suspend
+     (lambda (k-url)
+       `(html (a ([href ,k-url]) "Error"))))
+    (/ 1 0)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/hod-0618.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/hod-0618.ss
new file mode 100644
index 0000000000..e71bb36980
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/hod-0618.ss
@@ -0,0 +1,19 @@
+(module hod-0618 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout 30)
+  (define (start _)
+    `(html
+      (body
+       ,(extract-binding/single 
+         'test:case
+         (request-bindings
+          (send/suspend
+           (lambda (k-url)
+             `(html
+               (body
+                (form ([method "POST"]
+                       [action ,k-url])
+                      (input ([type "text"] [name "test:case"]))
+                      (input ([type "submit"])))))))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/inf-essence.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/inf-essence.ss
new file mode 100644
index 0000000000..98989df0a4
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/inf-essence.ss
@@ -0,0 +1,13 @@
+(module inf-essence mzscheme  
+  (define a (alarm-evt +inf.0))
+  
+  (let loop ()
+    (sync
+     (handle-evt a
+                 (lambda _
+                   (printf "Infinity has passed.~n")))
+     (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
+                               (* 1000 1)))
+                 (lambda _
+                   (printf "One second has passed.~n"))))
+    (loop)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/inf.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/inf.ss
new file mode 100644
index 0000000000..6ffee51d7c
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/inf.ss
@@ -0,0 +1,12 @@
+(module inf mzscheme
+  (provide interface-version timeout start)
+  
+  (define interface-version 'v1)
+  
+  (define timeout +inf.0)
+  
+  ; start : request -> response
+  (define (start initial-request) 
+    `(html (head (title "A Test Page"))
+           (body ([bgcolor "white"])
+                 (p "This is a simple module servlet.")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration-2.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration-2.ss
new file mode 100644
index 0000000000..07c76af031
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration-2.ss
@@ -0,0 +1,24 @@
+(module instance-expiration-2 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define timeout 5)
+  (define interface-version 'v2)
+  
+  (define (instance-expiration-handler expired-request)
+    ; Not allowed to call any (lib "servlet.ss" "web-server") methods
+    ; (I can't enforce this, however, so if you accidentally do weird things will happen.)
+    (send/suspend (lambda (k)
+                    `(html (head (title "You win.")) (body "You win.")))))
+  
+  (define (start initial-request)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html
+         (head (title "Instance expiration demo"))
+         (body (p (a ([href ,(embed/url 
+                              (lambda (request)
+                                `(html (head (title "Instance expiration demo"))
+                                       (body (p "Reload in a few minutes.")
+                                             (p "(or change the instance id to something made up.")))))])
+                     "Click this link."))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration.ss
new file mode 100644
index 0000000000..54edd46e17
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration.ss
@@ -0,0 +1,23 @@
+(module instance-expiration mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define timeout 5)
+  (define interface-version 'v2)
+  
+  (define (instance-expiration-handler expired-request)
+    ; Not allowed to call any (lib "servlet.ss" "web-server") methods
+    ; (I can't enforce this, however, so if you accidentally do weird things will happen.)
+    `(html (head (title "You win.")) (body "You win.")))
+  
+  (define (start initial-request)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html
+         (head (title "Instance expiration demo"))
+         (body (p (a ([href ,(embed/url 
+                              (lambda (request)
+                                `(html (head (title "Instance expiration demo"))
+                                       (body (p "Reload in a few minutes.")
+                                             (p "(or change the instance id to something made up.")))))])
+                     "Click this link."))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix-param.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix-param.ss
new file mode 100644
index 0000000000..f94c381af0
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix-param.ss
@@ -0,0 +1,11 @@
+(module jas01-fix-param mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide get-time)
+  
+  (define load-time
+    (make-web-cell:local #f))
+  
+  (define (get-time)
+    (web-cell:local-ref load-time))
+  
+  (web-cell:local-set! load-time (current-seconds)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
new file mode 100644
index 0000000000..e6a74d521a
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
@@ -0,0 +1,14 @@
+(module jas01-fix mzscheme
+  (require (lib "servlet.ss" "web-server")
+           "jas01-fix-param.ss")
+
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+
+  ; start : request -> response
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    `(html (head (title "Servlet Parameter Test"))
+           (body (h1 "Servlet Parameter Test")
+                 ,(number->string (get-time))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-param.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-param.ss
new file mode 100644
index 0000000000..d04ce39850
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-param.ss
@@ -0,0 +1,9 @@
+(module jas01-param mzscheme
+  (provide get-time)
+
+  (define load-time (make-parameter #f))
+
+  (define (get-time)
+    (load-time))
+
+  (load-time (current-seconds)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-test.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-test.ss
new file mode 100644
index 0000000000..b1d7eb2157
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-test.ss
@@ -0,0 +1,10 @@
+(module jas01-test mzscheme
+  (define start #f)
+  (thread-wait
+   (thread
+    (lambda ()
+      (set! start (dynamic-require "jas01.ss" 'start)))))
+  (thread-wait
+   (thread
+    (lambda ()
+      (printf "~S~n" (start 'foo))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
new file mode 100644
index 0000000000..c9dac7152d
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
@@ -0,0 +1,14 @@
+(module jas01 mzscheme
+  (require (lib "servlet.ss" "web-server")
+           "jas01-param.ss")
+
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+
+  ; start : request -> response
+  (define (start initial-request)
+    (report-errors-to-browser send/finish)
+    `(html (head (title "Servlet Parameter Test"))
+           (body (h1 "Servlet Parameter Test")
+                 ,(number->string (get-time))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/lock.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/lock.ss
new file mode 100644
index 0000000000..6e15bf4e3e
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/lock.ss
@@ -0,0 +1,24 @@
+(module lock mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v2-transitional)
+  (define timeout 60)
+  (define (instance-expiration-handler _)
+    `(html (body "Error")))
+  (define (start _)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (body 
+               (p (a ([href ,(embed/url
+                              (lambda _
+                                (sleep 5)
+                                (second "Slow")))])
+                     "Slow"))
+               (p (a ([href ,(embed/url
+                              (lambda _
+                                (second "Fast")))])
+                     "Fast")))))))
+  (define (second label)
+    `(html (body ,label
+                 ,(number->string (current-seconds))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/none-test.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/none-test.ss
new file mode 100644
index 0000000000..96df38bf74
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/none-test.ss
@@ -0,0 +1,10 @@
+(module none-test mzscheme
+  (require (lib "none.ss" "web-server" "managers"))
+  (provide (all-defined))
+  
+  (define interface-version 'v2-transitional)
+  (define manager (create-none-manager
+                   (lambda (failed-request)
+                     `(html (body (h2 "Error"))))))
+  (define (start initial-request)
+    `(html (body (h2 "Look Ma, No Instance!")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/plus.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/plus.ss
new file mode 100644
index 0000000000..902a702e9c
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/plus.ss
@@ -0,0 +1,28 @@
+(module plus mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "pretty.ss"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start _)
+    (define req
+      (send/suspend
+       (lambda (k-url)
+         `(html 
+           (body
+            (form ([action ,k-url] [method "POST"])
+                  (input ([type "checkbox"] [name "checkbox"]))
+                  (input ([type "text"] [name "text+foo"]))
+                  (input ([type "submit"] [name "submit"]))))))))
+    (define binds
+      (request-bindings req))
+    (define sport
+      (open-output-string))
+    (define pp
+      (parameterize ([current-output-port sport])
+        (pretty-print binds)))
+    `(html
+      (body
+       (pre
+        ,(get-output-string sport))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr5490.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr5490.ss
new file mode 100644
index 0000000000..755544e421
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/pr5490.ss
@@ -0,0 +1,8 @@
+(module pr5490 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 120)
+  (define (start ireq)
+    (send/finish '(("paul") "..."))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
new file mode 100644
index 0000000000..21d9bb836b
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
@@ -0,0 +1,19 @@
+(module pr5565 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 120)
+  (define (start ireq)
+    (define p
+      (send/suspend
+       (build-suspender `("Test of Page 2")
+                        `((input ([type "submit"][value "pls test with and without topping"]))))))    
+    (define q
+      (send/suspend
+       (build-suspender `("Bug")
+                        `((input ([type "text"][name "x"]))))))    
+    (define r (extract-binding/single `x (request-bindings q)))   
+    (send/suspend
+     (build-suspender `("Result of test")
+                      (list r)))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr7359.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7359.ss
new file mode 100644
index 0000000000..341848b0b2
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7359.ss
@@ -0,0 +1,12 @@
+(module pr7359 mzscheme
+  (require (lib "serialize.ss")
+           (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+
+  (define-serializable-struct foo ())
+  (define (start req)
+    (deserialize (serialize (make-foo)))
+    `(html (body "Made it"))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr7533.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7533.ss
new file mode 100644
index 0000000000..372ef37de5
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7533.ss
@@ -0,0 +1,19 @@
+(module pr7533 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start initial-request)
+    (define start-time (current-seconds))
+    (let loop ((last-time start-time))
+      (let ((time (current-seconds)))
+        (send/suspend
+         (lambda (k)
+           `(html
+             (form ((action ,k) (method "post"))
+                   (p ,(format "It has been ~a seconds since starting (~a seconds since last iteration)."
+                               (- time start-time)
+                               (- time last-time)))
+                   (input ((type "submit")))))))
+        (loop time)))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
new file mode 100644
index 0000000000..c86b989e4e
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
@@ -0,0 +1,10 @@
+(module pr7935-other mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  
+  (define (start initial-request)
+    ;(report-errors-to-browser send/back)
+    (/ 1 0)))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/ssd.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/ssd.ss
new file mode 100644
index 0000000000..65327e0f58
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/ssd.ss
@@ -0,0 +1,18 @@
+(module ssd mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout 120)
+  (define (start ir)
+    (printf "X~n")
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(html (head)
+              (body
+               (ul
+                ,@(map (lambda (i)
+                         `(li (a ([href ,(embed/url
+                                          (lambda (r)
+                                            `(html (head) (body ,i))))])
+                                 ,(number->string i))))
+                       `(1 2 3 4 5 6 7 8 9 0)))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/static.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/static.ss
new file mode 100644
index 0000000000..7e669a00f0
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/static.ss
@@ -0,0 +1,9 @@
+(module static mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define (start initial-request)
+    (list
+     #"text/html"
+     "<html><head></head><body>Foo</body><html>")))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/update.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/update.ss
new file mode 100644
index 0000000000..2057700245
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/update.ss
@@ -0,0 +1,11 @@
+(module update mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define timeout 60)
+  (define interface-version 'v1)
+  (define (start initial-request)
+    (send/back
+     `(html (head)
+            (body
+             (h1 "Hey"))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/utf8.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/utf8.ss
new file mode 100644
index 0000000000..ad0d2c251b
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/new-suite/utf8.ss
@@ -0,0 +1,17 @@
+(module utf8 mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  
+  (define interface-version 'v1)
+  (define timeout 60)
+  (define (start initial-request)
+    (extract-binding/single
+     'name
+     (request-bindings
+      (send/suspend
+       (lambda (k-url)
+         `(html
+           (body
+            (form ([action ,k-url])
+                  (input ([type "text"] [name "name"]))
+                  (input ([type "submit"])))))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/size.ss b/collects/web-server/default-web-root/servlets/tests/size.ss
index 23e3db0c2d..4c272a4812 100644
--- a/collects/web-server/default-web-root/servlets/tests/size.ss
+++ b/collects/web-server/default-web-root/servlets/tests/size.ss
@@ -1,23 +1,23 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-
-(let* ([line-size 80]
-       [build-a-str
-        (lambda (n)
-          (list->string (let loop ([n n])
-                          (cond
-                            [(zero? n) (list #\newline)]
-                            [else (cons #\a (loop (sub1 n)))]))))]
-       [line (build-a-str (sub1 line-size))]
-       [html-overhead 68])
-  (unit
-    (import servlet^)
-    (export)
-    
+(module size mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define line-size 80)
+  (define (build-a-str n)
+    (list->string (let loop ([n n])
+                    (cond
+                      [(zero? n) (list #\newline)]
+                      [else (cons #\a (loop (sub1 n)))]))))
+  (define line (build-a-str (sub1 line-size)))
+  (define html-overhead 68)
+  (define (start initial-request)
+    (define bindings (request-bindings initial-request))
     (define size (- (string->number (cdr (assq 'size bindings))) html-overhead))
     (define nlines (quotient size line-size))
     (define extra (remainder size line-size))
     
     `(html (head (title "A Page"))
            (body (p ,@(vector->list (make-vector nlines line))
-                    ,(build-a-str extra))))))
+                    ,(build-a-str extra))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/test.ss b/collects/web-server/default-web-root/servlets/tests/test.ss
index db7170d924..1bd7da8d20 100644
--- a/collects/web-server/default-web-root/servlets/tests/test.ss
+++ b/collects/web-server/default-web-root/servlets/tests/test.ss
@@ -1,9 +1,11 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server"))
-(let ([count 0])
-  (unit
-    (import servlet^)
-    (export)
+(module test mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  (define count 0)
+  
+  (define (start initial-request)
     (with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))])
       (set! count (add1 count))
       `(html (head (title "Testing 1...2...3"))
@@ -12,4 +14,4 @@
                       (br)
                       "Count = " ,(number->string count)
                       (br)
-                      ,(format "Here are the headers:~n~s~n" (request-headers initial-request))))))))
+                      ,(format "Here are the headers:~n~s~n" (request-headers initial-request))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/url.ss b/collects/web-server/default-web-root/servlets/tests/url.ss
index ffee691cda..65f027e329 100644
--- a/collects/web-server/default-web-root/servlets/tests/url.ss
+++ b/collects/web-server/default-web-root/servlets/tests/url.ss
@@ -1,10 +1,13 @@
-(require (lib "unit.ss")
-         (lib "servlet-sig.ss" "web-server")
-         (lib "url.ss" "net"))
-(let ([count 0])
-  (unit
-    (import servlet^)
-    (export)
+(module url mzscheme
+  (require (lib "servlet.ss" "web-server")
+           (lib "url.ss" "net"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define count 0)
+  
+  (define (start initial-request)
     (set! count (add1 count))
     `(html (head (title "URL Test"))
            (body (p "The method requested is: " ,(format "~s" (request-method initial-request)))
diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss
index a98e1bf7c0..2f87d5c8a1 100644
--- a/collects/web-server/dispatchers/dispatch-servlets.ss
+++ b/collects/web-server/dispatchers/dispatch-servlets.ss
@@ -2,7 +2,6 @@
   (require (lib "url.ss" "net")
            (lib "kw.ss")
            (lib "plt-match.ss")
-           (lib "unit.ss")
            (lib "string.ss")
            (lib "contract.ss"))
   (require "dispatch.ss"
@@ -11,7 +10,6 @@
            "../private/response.ss"
            "../response-structs.ss"
            "../servlet.ss"
-           "../sig.ss"
            "../private/configuration.ss"
            "../private/util.ss"
            "../managers/manager.ss"
@@ -308,14 +306,6 @@
     ;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
     ;;;; A response
     (define (load-servlet/path a-path)
-      (define (v0.servlet->v1.lambda servlet)
-        (lambda (initial-request)
-          (define servlet@ (unit-from-context servlet^))
-          (invoke-unit
-           (compound-unit 
-             (import) (export)
-             (link (((S : servlet^)) servlet@)
-                   (() servlet S))))))
       (define (v0.response->v1.lambda response-path response)
         (define go
           (box
@@ -333,16 +323,6 @@
         ; XXX load/use-compiled breaks errortrace
         (define s (load/use-compiled a-path))
         (cond
-          ;; signed-unit servlet
-          ; MF: I'd also like to test that s has the correct import signature.
-          [(unit? s) 
-           (make-servlet (current-custodian)
-                         (current-namespace)
-                         (create-timeout-manager
-                          default-servlet-instance-expiration-handler
-                          timeouts-servlet-connection
-                          timeouts-default-servlet)
-                         (v0.servlet->v1.lambda s))]
           ; FIX - reason about exceptions from dynamic require (catch and report if not already)
           ;; module servlet
           [(void? s)
@@ -359,7 +339,7 @@
                                  timeouts-servlet-connection
                                  timeout)
                                 (v1.module->v1.lambda timeout start)))]
-               [(v2-transitional) ; XXX: Undocumented
+               [(v2 v2-transitional) ; XXX: Undocumented
                 (let ([start (dynamic-require module-name 'start)]
                       [manager (with-handlers
                                    ([exn:fail:contract?
diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss
index adade47611..ec87e7344f 100644
--- a/collects/web-server/private/configure.ss
+++ b/collects/web-server/private/configure.ss
@@ -1,22 +1,22 @@
 (module configure mzscheme
-  (require (lib "unit.ss")
-           (lib "servlet-sig.ss" "web-server")
+  (require (lib "servlet.ss" "web-server")
            (lib "url.ss" "net")
            (lib "etc.ss")
            (lib "list.ss")
            (lib "pretty.ss")
            (lib "file.ss")
-           (lib "contract.ss")
            (only (lib "configuration.ss" "web-server")
                  default-configuration-table-path)
            (lib "configuration-table-structs.ss" "web-server" "private")
            (lib "parse-table.ss" "web-server" "private")
            (lib "configuration-util.ss" "web-server" "private")
            (lib "util.ss" "web-server" "private"))
-  (provide/contract
-   [servlet unit?]
-   ; XXX contract
-   [servlet-maker (string? . -> . unit?)])
+  (provide
+   interface-version timeout
+   start)
+  
+  (define timeout (* 12 60 60))
+  (define interface-version 'v1)
   
   ;; FIX
   ; - fuss with changing absolute paths into relative ones internally
@@ -30,780 +30,774 @@
   ; - change all configuration paths (in the configure servlet and in the server) to
   ;   use a platform independent representation (i.e. a listof strings)
   
-  ; servlet-maker : str -> (unit/sig servlet^ -> ())
-  (define (servlet-maker default-configuration-path)
-    (unit
-      (import servlet^)
-      (export)
-      
-      (define CONFIGURE-SERVLET-NAME "configure.ss")
-      (define WIDE "70")
-      
-      (adjust-timeout! (* 12 60 60))
-      (error-print-width 800) ; 10-ish lines
-      
-      ; passwords = (listof realm)
-      ; realm = (make-realm str str (listof user-pass))
-      (define-struct realm (name pattern allowed))
-      
-      ; user-pass = (make-user-pass sym str)
-      (define-struct user-pass (user pass))
-      
-      (define doc-dir "Defaults/documentation")
-      
-      (define edit-host-button-name "Edit Minor Details")
-      
-      ; build-footer : str -> html
-      (define (build-footer base)
-        (let ([scale (lambda (n) (number->string (round (/ n 4))))])
-          `(p "Powered by "
-              (a ([href "http://www.plt-scheme.org/"])
-                 (img ([width ,(scale 211)] [height ,(scale 76)]
-                                            [src ,(string-append base doc-dir "/plt-logo.gif")]))))))
-      
-      (define footer (build-footer "/"))
-      
-      ; access-error-page : html
-      (define access-error-page
-        `(html (head (title "Web Server Configuration Access Error"))
-               (body ([bgcolor "white"])
-                     (p "You must connect to the configuration tool from the machine the server runs on using 127.0.0.1 for the host part of the URL.")
-                     ,footer)))
-      
-      ; permission-error-page : path -> html
-      (define (permission-error-page configuration-path)
-        `(html (head (title "Web Server Configuration Permissions Error"))
-               (body ([bgcolor "white"])
-                     (p "You must have read and write access to "
-                        (code ,(path->string configuration-path))
-                        " in order to configure the server."))))
-      
-      ; check-ip-address : request -> request
-      (define (check-ip-address request)
-        (unless (string=? "127.0.0.1" (request-host-ip request))
-          (send/finish access-error-page))
-        request)
-      
-      (check-ip-address initial-request)
-      
-      (define web-base (directory-part default-configuration-path))
-      
-      ; more here - abstract with static pages?
-      (define web-server-icon
-        `(img ([src ,(string-append "/" doc-dir "/web-server.gif")]
-               ;[width "123"] [height "115"]
-               [width "61"] [height "57"])))
-      
-      ; interact : (str -> response) -> bindings
-      (define (interact page)
-        (request-bindings (check-ip-address (send/suspend page))))
-      
-      ; choose-configuration-file : -> doesn't
-      (define (choose-configuration-file)
-        (let ([configuration-path (ask-for-configuration-path)])
-          (let loop ()
-            (if (file-exists? configuration-path)
-                (let ([perms (file-or-directory-permissions configuration-path)])
-                  ; race condition - changing the permissions after the check
-                  ; will result in an exception later (which serves them right)
-                  (if (and (memq 'write perms) (memq 'read perms))
-                      (configure-top-level configuration-path)
-                      (send/finish (permission-error-page configuration-path))))
-                (begin (send/suspend (copy-configuration-file configuration-path))
-                       (with-handlers ([exn:fail:filesystem:exists? send-exn])
-                         (let-values ([(base name must-be-dir) (split-path configuration-path)])
-                           (ensure-directory-shallow base))
-                         (copy-file default-configuration-path configuration-path))
-                       (loop))))))
-      
-      ; copy-configuration-file : path -> html
-      (define (copy-configuration-file configuration-path)
-        (build-suspender
-         '("Copy Configuration File")
-         `((h1 "Copy Configuration File")
-           (p "The configuration file "
-              (blockquote (code ,(path->string configuration-path)))
-              "does not exist.  Would you like to copy the default configuration to this "
-              "location?")
-           (center (input ([type "submit"] [name "ok"] [value "Copy"]))))))
-      
-      ; ask-for-configuration-path : -> path
-      (define (ask-for-configuration-path)
-        (build-path
-         (extract-binding/single
-          'path
-          (request-bindings (send/suspend configuration-path-page)))))
-      
-      ; configuration-path-page : str -> html
-      (define configuration-path-page
-        (build-suspender
-         '("Choose a Configuration File")
-         `((h1 "Choose a Web Server Configuration File")
-           ,web-server-icon
-           (p "Choose a Web server configuration file to edit. "
-              (br)
-              "This Web server uses the configuration in "
-              (blockquote (code ,(path->string default-configuration-path))))
-           (table (tr (th "Configuration path")
-                      (td (input ([type "text"] [name "path"] [size ,WIDE]
-                                                [value ,(path->string default-configuration-path)]))))
-                  (tr (td ([colspan "2"] [align "center"])
-                          (input ([type "submit"] [name "choose-path"] [value "Select"]))))))))
-      
-      ; configure-top-level : path -> doesn't
-      (define (configure-top-level configuration-path)
-        (with-handlers ([exn:fail:filesystem:exists? send-exn])
-          (let ([original-configuration (read-configuration configuration-path)])
-            (let loop ([configuration original-configuration])
-              (let* ([update-bindings (interact (request-new-configuration-table configuration original-configuration))]
-                     [form-configuration
-                      (delete-hosts (update-configuration configuration update-bindings)
-                                    (foldr (lambda (b acc)
-                                             (if (string=? "Delete" (cdr b))
-                                                 (cons (symbol->string (car b)) acc)
-                                                 acc))
-                                           null
-                                           update-bindings))]
-                     [new-configuration
-                      (cond
-                        [(assq 'add-host update-bindings)
-                         (add-virtual-host form-configuration (extract-bindings 'host-prefixes update-bindings))]
-                        [(reverse-assoc edit-host-button-name update-bindings)
-                         =>
-                         (lambda (edit)
-                           ; write the configuration twice when editing a host: once before and once after.
-                           ; The after may never happen if the user doesn't continue
-                           (write-configuration form-configuration configuration-path)
-                           (configure-hosts form-configuration (string->number (symbol->string (car edit)))))]
-                        [else form-configuration])])
-                (write-configuration new-configuration configuration-path)
-                (loop new-configuration))))))
-      
-      ; switch-to-current-port : configuration-table -> (U #f configuration-table)
-      ; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
-      ; perhaps the server could include it?
-      '(define (switch-to-current-port old)
-         (let ([current-port (url-port (request-uri initial-request))])
-           (and (not (= current-port (configuration-table-port old)))
-                (make-configuration-table
-                 current-port
-                 (configuration-table-max-waiting old)
-                 (configuration-table-initial-connection-timeout old)
-                 (configuration-table-default-host old)
-                 (configuration-table-virtual-hosts old)))))
-      
-      ; send-exn : tst -> doesn't
-      (define (send-exn exn)
-        (send/back (exception-error-page exn)))
-      
-      ; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a))
-      (define (reverse-assoc x lst)
-        (cond
-          [(null? lst) #f]
-          [else (if (equal? x (cdar lst))
-                    (car lst)
-                    (reverse-assoc x (cdr lst)))]))
-      
-      ; add-virtual-host : configuration-table (listof str) -> configuration-table
-      (define (add-virtual-host conf existing-prefixes)
-        (update-hosts conf (cons (cons "my-host.my-domain.org"
-                                       (configuration-table-default-host conf))
-                                 (configuration-table-virtual-hosts conf))))
-      
-      ; update-hosts : configuration-table (listof (cons str host-table))
-      (define (update-hosts conf new-hosts)
-        (make-configuration-table
-         (configuration-table-port conf)
-         (configuration-table-max-waiting conf)
-         (configuration-table-initial-connection-timeout conf)
-         (configuration-table-default-host conf)
-         new-hosts))
-      
-      ; delete-hosts : configuration-table (listof str) -> configuration-table
-      ; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
-      (define (delete-hosts conf to-delete)
-        ; the if is not needed, it just avoids some work
-        (if (null? to-delete)
-            conf
-            (update-hosts
-             conf
-             (drop (configuration-table-virtual-hosts conf) to-delete))))
-      
-      ; drop : (listof a) (listof str) -> (listof a)
-      ; pre: (apply < to-delete)
-      ; to delete the entries in to-filter indexed by to-delete
-      (define (drop to-filter to-delete)
-        (let loop ([to-filter to-filter] [to-delete (map string->number to-delete)] [i 0])
-          (cond
-            [(null? to-delete) to-filter]
-            [else (if (= i (car to-delete))
-                      (loop (cdr to-filter) (cdr to-delete) (add1 i))
-                      (cons (car to-filter) (loop (cdr to-filter) to-delete (add1 i))))])))
-      
-      ; configure-hosts : configuration-table (U #f nat) -> configuration-table
-      ; n is either the virtual host number or #f for the default virtual host
-      (define (configure-hosts old n)
-        (if n
-            (update-hosts old
-                          ; more here - consider restructuring this map.  Perhaps it is fine.
-                          ; Perhaps it should short circuit.  Perhaps the number of virtual hosts
-                          ; is small so it doesn't matter. Perhaps that is a sloppy way to think/program.
-                          ; The code is really a functional array update except it's on a list.
-                          (map (lambda (host this-n)
-                                 (if (= n this-n)
-                                     (cons (car host) (configure-host (cdr host)))
-                                     host))
-                               (configuration-table-virtual-hosts old)
-                               (build-list (length (configuration-table-virtual-hosts old)) (lambda (x) x))))
+  (define default-configuration-path default-configuration-table-path)
+  (define (set-config-path! new)
+    (set! default-configuration-path new))
+  
+  (define CONFIGURE-SERVLET-NAME "configure.ss")
+  (define WIDE "70")
+  
+  ; passwords = (listof realm)
+  ; realm = (make-realm str str (listof user-pass))
+  (define-struct realm (name pattern allowed))
+  
+  ; user-pass = (make-user-pass sym str)
+  (define-struct user-pass (user pass))
+  
+  (define doc-dir "Defaults/documentation")
+  
+  (define edit-host-button-name "Edit Minor Details")
+  
+  ; build-footer : str -> html
+  (define (build-footer base)
+    (let ([scale (lambda (n) (number->string (round (/ n 4))))])
+      `(p "Powered by "
+          (a ([href "http://www.plt-scheme.org/"])
+             (img ([width ,(scale 211)] [height ,(scale 76)]
+                                        [src ,(string-append base doc-dir "/plt-logo.gif")]))))))
+  
+  (define footer (build-footer "/"))
+  
+  ; access-error-page : html
+  (define access-error-page
+    `(html (head (title "Web Server Configuration Access Error"))
+           (body ([bgcolor "white"])
+                 (p "You must connect to the configuration tool from the machine the server runs on using 127.0.0.1 for the host part of the URL.")
+                 ,footer)))
+  
+  ; permission-error-page : path -> html
+  (define (permission-error-page configuration-path)
+    `(html (head (title "Web Server Configuration Permissions Error"))
+           (body ([bgcolor "white"])
+                 (p "You must have read and write access to "
+                    (code ,(path->string configuration-path))
+                    " in order to configure the server."))))
+  
+  ; check-ip-address : request -> request
+  (define (check-ip-address request)
+    (unless (string=? "127.0.0.1" (request-host-ip request))
+      (send/finish access-error-page))
+    request)
+    
+  (define web-base (directory-part default-configuration-path))
+  
+  ; more here - abstract with static pages?
+  (define web-server-icon
+    `(img ([src ,(string-append "/" doc-dir "/web-server.gif")]
+           ;[width "123"] [height "115"]
+           [width "61"] [height "57"])))
+  
+  ; interact : (str -> response) -> bindings
+  (define (interact page)
+    (request-bindings (check-ip-address (send/suspend page))))
+  
+  ; choose-configuration-file : -> doesn't
+  (define (choose-configuration-file)
+    (let ([configuration-path (ask-for-configuration-path)])
+      (let loop ()
+        (if (file-exists? configuration-path)
+            (let ([perms (file-or-directory-permissions configuration-path)])
+              ; race condition - changing the permissions after the check
+              ; will result in an exception later (which serves them right)
+              (if (and (memq 'write perms) (memq 'read perms))
+                  (configure-top-level configuration-path)
+                  (send/finish (permission-error-page configuration-path))))
+            (begin (send/suspend (copy-configuration-file configuration-path))
+                   (with-handlers ([exn:fail:filesystem:exists? send-exn])
+                     (let-values ([(base name must-be-dir) (split-path configuration-path)])
+                       (ensure-directory-shallow base))
+                     (copy-file default-configuration-path configuration-path))
+                   (loop))))))
+  
+  ; copy-configuration-file : path -> html
+  (define (copy-configuration-file configuration-path)
+    (build-suspender
+     '("Copy Configuration File")
+     `((h1 "Copy Configuration File")
+       (p "The configuration file "
+          (blockquote (code ,(path->string configuration-path)))
+          "does not exist.  Would you like to copy the default configuration to this "
+          "location?")
+       (center (input ([type "submit"] [name "ok"] [value "Copy"]))))))
+  
+  ; ask-for-configuration-path : -> path
+  (define (ask-for-configuration-path)
+    (build-path
+     (extract-binding/single
+      'path
+      (request-bindings (send/suspend configuration-path-page)))))
+  
+  ; configuration-path-page : str -> html
+  (define configuration-path-page
+    (build-suspender
+     '("Choose a Configuration File")
+     `((h1 "Choose a Web Server Configuration File")
+       ,web-server-icon
+       (p "Choose a Web server configuration file to edit. "
+          (br)
+          "This Web server uses the configuration in "
+          (blockquote (code ,(path->string default-configuration-path))))
+       (table (tr (th "Configuration path")
+                  (td (input ([type "text"] [name "path"] [size ,WIDE]
+                                            [value ,(path->string default-configuration-path)]))))
+              (tr (td ([colspan "2"] [align "center"])
+                      (input ([type "submit"] [name "choose-path"] [value "Select"]))))))))
+  
+  ; configure-top-level : path -> doesn't
+  (define (configure-top-level configuration-path)
+    (with-handlers ([exn:fail:filesystem:exists? send-exn])
+      (let ([original-configuration (read-configuration configuration-path)])
+        (let loop ([configuration original-configuration])
+          (let* ([update-bindings (interact (request-new-configuration-table configuration original-configuration))]
+                 [form-configuration
+                  (delete-hosts (update-configuration configuration update-bindings)
+                                (foldr (lambda (b acc)
+                                         (if (string=? "Delete" (cdr b))
+                                             (cons (symbol->string (car b)) acc)
+                                             acc))
+                                       null
+                                       update-bindings))]
+                 [new-configuration
+                  (cond
+                    [(assq 'add-host update-bindings)
+                     (add-virtual-host form-configuration (extract-bindings 'host-prefixes update-bindings))]
+                    [(reverse-assoc edit-host-button-name update-bindings)
+                     =>
+                     (lambda (edit)
+                       ; write the configuration twice when editing a host: once before and once after.
+                       ; The after may never happen if the user doesn't continue
+                       (write-configuration form-configuration configuration-path)
+                       (configure-hosts form-configuration (string->number (symbol->string (car edit)))))]
+                    [else form-configuration])])
+            (write-configuration new-configuration configuration-path)
+            (loop new-configuration))))))
+  
+  ; switch-to-current-port : configuration-table -> (U #f configuration-table)
+  ; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
+  ; perhaps the server could include it?
+  #;(define (switch-to-current-port old)
+     (let ([current-port (url-port (request-uri initial-request))])
+       (and (not (= current-port (configuration-table-port old)))
             (make-configuration-table
-             (configuration-table-port old)
+             current-port
              (configuration-table-max-waiting old)
              (configuration-table-initial-connection-timeout old)
-             (configure-host (configuration-table-default-host old))
-             (configuration-table-virtual-hosts old))))
-      
-      ; configure-host : host-table -> host-table
-      (define (configure-host old)
-        (let* ([bindings (interact (request-new-host-table old))]
-               [new (update-host-table old bindings)])
-          (when (assq 'edit-passwords bindings)
-            (let* ([paths (host-table-paths new)]
-                   [password-path
-                    ;; build-path-unless-absolute is defined in configuration.ss
-                    (build-path-unless-absolute
-                     (build-path-unless-absolute web-base (paths-host-base paths))
-                     (paths-passwords paths))])
-              (unless (file-exists? password-path)
-                (write-to-file password-path ''()))
-              (configure-passwords password-path)))
-          new))
-      
-      (define restart-message
-        `((h3 (font ([color "red"]) "Restart the Web server to use the new settings."))))
-      
-      ; request-new-configuration-table : configuration-table configuration-table -> str -> html
-      (define (request-new-configuration-table old orig)
-        (build-suspender
-         '("PLT Web Server Configuration")
-         `((h1 "PLT Web Server Configuration Management")
-           ,web-server-icon
-           "copyright 2001 by Paul Graunke and PLT"
-           (hr)
-           (h2 "Basic Configuration")
-           (table
-            ,(make-tr-num "Port" 'port (configuration-table-port old))
-            ,(make-tr-num "Maximum Waiting Connections"
-                          'waiting (configuration-table-max-waiting old))
-            ,(make-tr-num "Initial Connection Timeout (seconds)" 'time-initial
-                          (configuration-table-initial-connection-timeout old)))
-           (hr)
-           (h2 "Host Name Configuration")
-           (p "The Web server accepts requests on behalf of multiple " (em "hosts")
-              " each corresponding to a domain name."
-              " The table below maps domain names to host specific configurations.")
-           (table ([width "50%"])
-                  (tr (th ([align "left"]) "Name") ;(th "Host configuration path")
-                      (th "Host Directory")
-                      (th nbsp)
-                      (th nbsp))
-                  (tr (td ,"Default Host")
-                      (td ,(make-field-size "text" 'default-host-root
-                                            (table->host-root (configuration-table-default-host old))
-                                            WIDE))
-                      (td ([align "center"])
-                          (input ([type "submit"] [name "default"] [value ,edit-host-button-name])))
-                      (td nbsp))
-                  ,@(map (lambda (host n)
-                           `(tr (td ,(make-field "text" 'host-regexps (car host)))
-                                (td ,(make-field-size "text" 'host-roots (table->host-root (cdr host)) WIDE))
-                                (td ([align "center"])
-                                    (input ([type "submit"] [name ,n] [value ,edit-host-button-name])))
-                                (td ([align "center"])
-                                    (input ([type "submit"] [name ,n] [value "Delete"])))))
-                         (configuration-table-virtual-hosts old)
-                         (build-list (length (configuration-table-virtual-hosts old)) number->string))
-                  (tr (td (input ([type "submit"] [name "add-host"] [value "Add Host"])))
-                      (td nbsp); (input ([type "submit"] [name "configure"] [value "Delete"]))
-                      ;(td (input ([type "submit"] [name "edit-host-details"] [value "Edit"])))
-                      (td nbsp)))
-           (hr)
-           (table ([width "90%"])
-                  ,@(if (equal? old orig) ; This only tests eq? because structures are more opaque now.
-                        null
-                        `((tr (td ,@restart-message))))
-                  (tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"])))))
-           (hr)
-           ,footer)))
-      
-      ; table->host-root : host-table -> str
-      (define (table->host-root t)
-        (path->string (build-path-unless-absolute web-base (paths-host-base (host-table-paths t)))))
-      
-      ; gen-make-tr : nat -> xexpr sym str [xexpr ...] -> xexpr
-      (define (gen-make-tr size-n)
-        (let ([size-str (number->string size-n)])
-          (lambda (label tag default-text . extra-tds)
-            `(tr (td (a ([href ,(format "/~a/terms/~a.html" doc-dir tag)]) ,label))
-                 (td ,(make-field-size "text" tag (format "~a" default-text) size-str))
-                 . ,extra-tds))))
-      
-      (define make-tr-num (gen-make-tr 20))
-      
-      (define make-tr-str (gen-make-tr 70))
-      
-      ; make-field : str sym str -> xexpr
-      (define (make-field type label value)
-        (make-field-size type label value "30"))
-      
-      ; make-field-size : str sym str str -> xexpr
-      (define (make-field-size type label value size)
-        `(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size])))
-      
-      ; update-configuration : configuration-table bindings -> configuration-table
-      (define (update-configuration old bindings)
-        (let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path
-          (make-configuration-table
-           (string->nat (extract-binding/single 'port bindings))
-           (string->nat (extract-binding/single 'waiting bindings))
-           (string->num (extract-binding/single 'time-initial bindings))
-           (update-host-root (configuration-table-default-host old)
-                             (ubp (build-path (extract-binding/single 'default-host-root bindings))))
-           (map (lambda (h root pattern)
-                  (cons pattern (update-host-root (cdr h) (ubp (build-path root)))))
-                (configuration-table-virtual-hosts old)
-                (extract-bindings 'host-roots bindings)
-                (extract-bindings 'host-regexps bindings)))))
-      
-      ; update-host-root : host-table str -> host-table
-      (define (update-host-root host new-root)
-        (host-table<-paths host (paths<-host-base (host-table-paths host) new-root)))
-      
-      ; host-table<-paths : host-table paths -> host-table
-      ; more here - create these silly functions automatically from def-struct macro
-      (define (host-table<-paths host paths)
-        (make-host-table
-         (host-table-indices host)
-         (host-table-log-format host)
-         (host-table-messages host)
-         (host-table-timeouts host)
-         paths))
-      
-      ; paths<-host-base : paths str -> paths
-      ; more here - create these silly functions automatically from def-struct macro
-      (define (paths<-host-base paths host-base)
-        (make-paths (paths-conf paths)
-                    host-base
-                    (paths-log paths)
-                    (paths-htdocs paths)
-                    (paths-servlet paths)
-                    (paths-mime-types paths)
-                    (paths-passwords paths)))
-      
-      ; string->num : str -> nat
-      (define (string->num str)
-        (or (string->number str) (error 'string->nat "~s is not a number" str)))
-      
-      ; string->nat : str -> nat
-      (define (string->nat str)
-        (let ([n (string->number str)])
-          (if (and n (integer? n) (exact? n) (>= n 0))
-              n
-              (error 'string->nat "~s is not exactly a natural number" str))))
-      
-      ; request-new-host-table : host-table -> str -> response
-      (define (request-new-host-table old)
-        (let* ([timeouts (host-table-timeouts old)]
-               [paths (host-table-paths old)]
-               [m (host-table-messages old)]
-               [host-root (build-path-unless-absolute web-base (paths-host-base paths))]
-               [conf (build-path-unless-absolute host-root (paths-conf paths))])
-          (build-suspender
-           '("Configure Host")
-           `((h1 "PLT Web Server Host configuration")
-             (input ([type "submit"] [value "Save Configuration"]))
-             (hr)
-             (table
-              (tr (th ([colspan "2"]) "Paths"))
-              ,(make-tr-str "Log file"
-                            'path-log (build-path-unless-absolute host-root (paths-log paths)))
-              ,(make-tr-str "Web document root"
-                            'path-htdocs (build-path-unless-absolute host-root (paths-htdocs paths)))
-              ,(make-tr-str "Servlet root"
-                            'path-servlet (build-path-unless-absolute host-root (paths-servlet paths)))
-              ,(make-tr-str "MIME Types"
-                            'path-mime-types (build-path-unless-absolute host-root (paths-mime-types paths)))
-              ,(make-tr-str "Password File"
-                            'path-password (build-path-unless-absolute host-root (paths-passwords paths)))
-              (tr (td ([colspan "2"])
-                      ,(make-field "submit" 'edit-passwords "Edit Passwords")))
-              (tr (td ([colspan "2"]) (hr)))
-              (tr (th ([colspan "2"]) "Message Paths"))
-              ,(make-tr-str "Servlet error" 'path-servlet-message
-                            (build-path-unless-absolute conf (messages-servlet m)))
-              ,(make-tr-str "Access Denied" 'path-access-message
-                            (build-path-unless-absolute conf (messages-authentication m)))
-              ,(make-tr-str "Servlet cache refreshed" 'servlet-refresh-message
-                            (build-path-unless-absolute conf (messages-servlets-refreshed m)))
-              ,(make-tr-str "Password cache refreshed" 'password-refresh-message
-                            (build-path-unless-absolute conf (messages-passwords-refreshed m)))
-              ,(make-tr-str "File not found" 'path-not-found-message
-                            (build-path-unless-absolute conf (messages-file-not-found m)))
-              ,(make-tr-str "Protocol error" 'path-protocol-message
-                            (build-path-unless-absolute conf (messages-protocol m)))
-              ,(make-tr-str "Collect garbage" 'path-collect-garbage-message
-                            (build-path-unless-absolute conf (messages-collect-garbage m)))
-              (tr (td ([colspan "2"]) (hr)))
-              (tr (th ([colspan "2"]) "Timeout Seconds"))
-              ,(make-tr-num "Default Servlet" 'time-default-servlet (timeouts-default-servlet timeouts))
-              ,(make-tr-num "Password" 'time-password (timeouts-password timeouts))
-              ,(make-tr-num "Servlet Connection" 'time-servlet-connection (timeouts-servlet-connection timeouts))
-              ,(make-tr-num "per Byte When Transfering Files" 'time-file-per-byte (timeouts-file-per-byte timeouts))
-              ,(make-tr-num "Base When Transfering Files" 'time-file-base (timeouts-file-base timeouts)))
-             (hr)
-             (input ([type "submit"] [value "Save Configuration"]))
-             ,footer))))
-      
-      ; update-host-table : host-table (listof (cons sym str)) -> host-table
-      (define (update-host-table old bindings)
-        (let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))]
-               [paths (host-table-paths old)]
-               [host-root (paths-host-base paths)]
-               [expanded-host-root (build-path-unless-absolute web-base host-root)]
-               [conf (build-path-unless-absolute expanded-host-root (paths-conf paths))]
-               [ubp (un-build-path expanded-host-root)]
-               [eb-host-root (lambda (tag) (ubp (eb tag)))]
-               [ubp-conf (un-build-path conf)]
-               [eb-conf (lambda (tag) (ubp-conf (eb tag)))])
-          (make-host-table
-           (host-table-indices old)
-           (host-table-log-format old)
-           (apply make-messages
-                  (map eb-conf '(path-servlet-message path-access-message servlet-refresh-message password-refresh-message path-not-found-message path-protocol-message path-collect-garbage-message)))
-           (apply make-timeouts
-                  (map (lambda (tag) (string->number (extract-binding/single tag bindings)))
-                       '(time-default-servlet time-password time-servlet-connection time-file-per-byte time-file-base)))
-           (let ([old-paths (host-table-paths old)])
-             (apply make-paths
-                    (paths-conf old-paths)
-                    ((un-build-path web-base)
-                     (build-path (paths-host-base old-paths)))
-                    (map eb-host-root '(path-log path-htdocs path-servlet path-mime-types path-password)))))))
-      
-      ; un-build-path : path -> path -> string
-      ; (GregP) Theory: this should return a string not a path so that the result can be
-      ;                 written to the configuration file.
-      (define (un-build-path possible-base)
-        (let ([base-list (path->list possible-base)])
-          (lambda (path)
-            (let ([path-list (path->list path)])
-              (cond
-                [(suffix base-list path-list)
-                 => (lambda (x) (path->string (apply build-path x)))]
-                [else
-                 (path->string path)])))))
-      
-      ; suffix : (listof a) (listof a) -> (U #f (listof a))
-      ; to return the extra elements in b after removing all elements from a in order
-      (define (suffix a b)
-        (cond
-          [(null? a) (if (null? b) #f b)]
-          [else (cond
-                  [(null? b) #f]
-                  [else (and (equal? (car a) (car b))
-                             (suffix (cdr a) (cdr b)))])]))
-      
-      ; Password Configuration
-      
-      ; configure-passwords : path -> void
-      (define (configure-passwords password-path)
-        (edit-passwords
-         password-path
-         (if (file-exists? password-path)
-             (call-with-input-file password-path read-passwords)
-             null)))
-      
-      ; edit-passwords : path passwords -> passwords
-      (define (edit-passwords which-one passwords)
-        (let* ([bindings (interact (password-updates which-one passwords))]
-               [to-deactivate (extract-bindings 'deactivate bindings)]
-               [again
-                (lambda (new-passwords)
-                  (write-to-file which-one (format-passwords new-passwords))
-                  (edit-passwords which-one new-passwords))])
-          (cond
-            [(assq 'edit bindings)
-             => (lambda (edit)
-                  (again (drop (map (let ([to-edit (string->number (cdr edit))])
-                                      (lambda (r n)
-                                        (if (= to-edit n)
-                                            (edit-realm r)
-                                            r)))
-                                    passwords
-                                    (build-list (length passwords) (lambda (x) x)))
-                               to-deactivate)))]
-            [(assq 'add bindings)
-             (again (cons (make-realm "new realm" "" null)
-                          (drop passwords to-deactivate)))]
-            [else (drop passwords to-deactivate)])))
-      
-      ; password-updates : path passwords -> request
-      (define (password-updates which-one passwords)
-        (let ([which-one (path->string which-one)])
-          (build-suspender
-           `("Updating Passwords for " ,which-one)
-           `((h1 "Updating Passwords for ")
-             (h3 ,which-one)
-             (h2 "You may wish to " (font ([color "red"]) "backup") " this password file.")
-             (p "Each authentication " (em "realm") " password protects URLs that match a pattern. "
-                "Choose a realm to edit below:")
-             (table
-              (tr (th "Realm Name") (th "Delete") (th "Edit"))
-              . ,(map (lambda (realm n)
-                        `(tr (td ,(realm-name realm))
-                             (td ,(make-field "checkbox" 'deactivate n))
-                             (td ,(make-field "radio" 'edit n))))
-                      passwords
-                      (build-list (length passwords) number->string)))
-             ,(make-field "submit" 'add "Add Realm")
-             ,(make-field "submit" 'edit-button "Edit")
-             ,footer))))
-      
-      ; edit-realm : realm -> realm
-      (define (edit-realm realm)
-        (let* ([bindings (interact (realm-updates realm))]
-               [new-name (extract-binding/single 'realm-name bindings)]
-               [new-pattern (extract-binding/single 'realm-pattern bindings)]
-               [new-allowed
-                (drop (map (lambda (u p) (make-user-pass (string->symbol u) p))
-                           (extract-bindings 'user bindings)
-                           (extract-bindings 'pass bindings))
-                      (extract-bindings 'deactivate bindings))])
-          ; more here - check something?  Everything is a string or symbol, though.
-          (cond
-            [(assq 'add-user bindings)
-             (edit-realm (make-realm new-name new-pattern
-                                     (cons (make-user-pass 'ptg "Scheme-is-cool!") new-allowed)))]
-            [(assq 'update bindings)
-             (make-realm new-name new-pattern new-allowed)]
-            [else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)])))
-      
-      ; realm-updates : realm -> request
-      (define (realm-updates realm)
-        (build-suspender
-         `("Update Authentication Realm " ,(realm-name realm))
-         `((h1 "Update Authentication Realm")
-           (table
-            ,(make-tr-str "Realm Name" 'realm-name (realm-name realm))
-            ,(make-tr-str "Protected URL Path Pattern" 'realm-pattern (realm-pattern realm)))
-           (hr)
-           (table
-            (tr (th "User Name") (th "Password") (th "Delete"))
-            . ,(map (lambda (x n)
-                      `(tr (td ,(make-field "text" 'user (symbol->string (user-pass-user x))))
-                           (td ,(make-field "text" 'pass (user-pass-pass x)))
-                           (td ,(make-field "checkbox" 'deactivate n))))
-                    (realm-allowed realm)
-                    (build-list (length (realm-allowed realm)) number->string)))
-           (input ([type "submit"] [name "add-user"] [value "Add User"]))
-           (input ([type "submit"] [name "update"] [value "Update Realm"]))
-           ,footer)))
-      
-      ; read-passwords : iport -> passwords
-      ; only works if the file starts with (quote ...)
-      (define (read-passwords in)
-        (let ([raw (read in)])
-          (unless (and (pair? raw) (eq? 'quote (car raw))
-                       (null? (cddr raw)))
-            (error 'read-passwords "The password file must be quoted to use the configuration tool."))
-          (map (lambda (raw-realm)
-                 ; more here - error checking
-                 (make-realm (car raw-realm)
-                             (cadr raw-realm)
-                             (map (lambda (x) (make-user-pass (car x) (cadr x)))
-                                  (cddr raw-realm))))
-               (cadr raw))))
-      
-      ; format-passwords : passwords -> s-expr
-      (define (format-passwords passwords)
-        (list 'quote
-              (map (lambda (r)
-                     (list* (realm-name r)
-                            (realm-pattern r)
-                            (map (lambda (x)
-                                   (list (user-pass-user x) (user-pass-pass x)))
-                                 (realm-allowed r))))
-                   passwords)))
-      
-      ; Little Helpers
-      
-      ; initialization-error-page : response
-      (define initialization-error-page
-        `(html (head (title "Web Server Configuration Program Invocation Error"))
-               (body ([bgcolor "white"])
-                     (p "Please direct your browser directly to the "
-                        (a ([href ,(url->string (request-uri initial-request))]) "configuration program,")
-                        " not through another URL.")
-                     ,footer)))
-      
-      ; done-page : html
-      (define done-page
-        ; more-here - consider adding more useful information
-        `(html (head (title "done"))
-               (body ([bgcolor "white"])
-                     (h2 "Configuration Saved.")
-                     (p "Click your browser's back button to continue configuring the server.")
-                     ,footer)))
-      
-      ; exception-error-page : TST -> html
-      (define (exception-error-page exn)
-        `(html (head (title "Error"))
-               (body ([bgcolor "white"])
-                     (p "Servlet exception: "
-                        (pre ,(exn->string exn)))
-                     ,footer)))
-      
-      (define must-select-host-page
-        `(html (head (title "Web Server Configuration Error"))
-               (body ([bgcolor "white"])
-                     (p "Please select which host to edit before clicking the Edit button.")
-                     ,footer)))
-      
-      ; io
-      
-      ; read-configuration : path -> configuration-table
-      (define (read-configuration configuration-path)
-        (parse-configuration-table (call-with-input-file configuration-path read)))
-      
-      ; write-configuration : configuration-table path -> void
-      ; writes out the new configuration file and
-      ; also copies the configure.ss servlet to the default-host's servlet directory
-      (define (write-configuration new configuration-path)
-        (ensure-configuration-servlet configuration-path (configuration-table-default-host new))
-        (ensure-configuration-paths new)
-        (write-configuration-table new configuration-path))
-      
-      ; ensure-configuration-servlet : path host-table -> void
-      (define (ensure-configuration-servlet configuration-path host)
-        (let* ([paths (host-table-paths host)]
-               [root (build-path-unless-absolute web-base
-                                                 (paths-host-base paths))]
-               [servlets-path
-                (build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
-          (ensure-config-servlet configuration-path servlets-path)
-          (let ([defaults (build-path "Defaults")])
-            (ensure* (collection-path "web-server" "default-web-root" "htdocs")
-                     (build-path-unless-absolute root (paths-htdocs paths))
-                     defaults))))
-      
-      ; ensure-configuration-paths : configuration-table -> void
-      ; to ensure that all the referenced config files exist for an entire configuration
-      (define (ensure-configuration-paths configuration)
-        (ensure-host-configuration (configuration-table-default-host configuration))
-        (for-each (lambda (x) (ensure-host-configuration (cdr x)))
-                  (configuration-table-virtual-hosts configuration)))
-      
-      ; ensure-host-configuration : host-table -> void
-      ; to ensure that all the referenced config files exist for a virtual host
-      (define (ensure-host-configuration host)
-        (let* ([paths (host-table-paths host)]
-               [host-base (build-path-unless-absolute web-base (paths-host-base paths))]
-               [conf (build-path-unless-absolute host-base (paths-conf paths))]
-               [log (build-path-unless-absolute host-base (paths-log paths))])
-          ; skip passwords since a missing file is an okay default
-          (ensure-directory-shallow conf)
-          (ensure-directory-shallow host-base)
-          ;(ensure-file log ...) ; empty log file is okay
-          (ensure-directory-shallow (build-path-unless-absolute host-base (paths-htdocs paths)))
-          (ensure-directory-shallow (build-path-unless-absolute host-base (paths-servlet paths)))
-          (let* ([messages (host-table-messages host)]
-                 ; more here maybe - check default config file instead? maybe not
-                 [from-conf (collection-path "web-server" "default-web-root" "conf")]
-                 [copy-conf
-                  (lambda (from to)
-                    (let ([to-path (build-path-unless-absolute conf to)])
-                      ; more here - check existance of from path?
-                      (copy-file* (build-path from-conf from) to-path)))])
-            (copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
-            (copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))
-            (copy-conf "forbidden.html" (messages-authentication messages))
-            (copy-conf "protocol-error.html" (messages-protocol messages))
-            (copy-conf "not-found.html" (messages-file-not-found messages))
-            (copy-conf "servlet-error.html" (messages-servlet messages))
-            (copy-conf "collect-garbage.html" (messages-collect-garbage messages)))))
-      
-      ; ensure-file : path path path -> void
-      ; to copy (build-path from name) to (build-path to name), creating directories as
-      ; needed if the latter does not already exist.
-      (define (ensure-file from to name)
-        (let ([to (simplify-path to)])
-          (ensure-directory-shallow to)
-          (let ([to-path (build-path to name)])
-            (unless (file-exists? to-path)
-              (copy-file (build-path from name) to-path)))))
-      
-      ; copy-file* : str str -> void
-      (define (copy-file* from-path to-path)
-        (unless (file-exists? to-path)
-          (let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)])
-            (ensure-directory-shallow to-path-base))
-          (copy-file from-path to-path)))
-      
-      ; ensure* : path path path -> void
-      ;; GregP: Don't know what the heck this does (thanks Paul)
-      ;;        but the first two arguments are now paths.
-      (define (ensure* from to name)
-        (ensure-directory-shallow to)
-        (let ([p (build-path from name)])
-          (cond
-            [(directory-exists? p)
-             (unless (member (path->string name) '("CVS" ".svn")) ; yuck
-               (let ([dest (build-path to name)])
-                 (ensure-directory-shallow dest)
-                 (for-each (lambda (x) (ensure* p dest x))
-                           (directory-list p))))]
-            [(file-exists? p)
-             (ensure-file from to name)])))
-      
-      ; ensure-directory-shallow : path -> void
-      (define (ensure-directory-shallow to)
-        (unless (directory-exists? to)
-          ; race condition - someone else could make the directory
-          (make-directory* to)))
-      
-      ; ensure-config-servlet : str path -> void
-      ; to create, if necessary, a stub configuration servlet that includes the main configuration servlet
-      ; at the desired location in a new web tree
-      (define (ensure-config-servlet configuration-path servlets-path)
-        (ensure-directory-shallow servlets-path)
-        (let ([file-path (build-path servlets-path CONFIGURE-SERVLET-NAME)])
-          (unless (file-exists? file-path) ; more here - check that it's a well formed servlet?
-            (call-with-output-file
-                file-path
-              (lambda (out)
-                (pretty-print
-                 `(require (lib ,CONFIGURE-SERVLET-NAME "web-server"))
-                 out)
-                (newline out)
-                (pretty-print
-                 `(servlet-maker ,(path->string configuration-path))
-                 out))))))
-      
-      ; extract-definition : sym (listof s-expr) -> s-expr
-      ; to return the rhs from (def name rhs) not (def (name . args) body)
-      (define (extract-definition name defs)
-        (or (ormap (lambda (def)
-                     (and (pair? def) (eq? 'define (car def))
-                          (pair? (cdr def)) (eq? name (cadr def))
-                          (pair? (cddr def))
-                          (caddr def)))
-                   defs)
-            (error 'extract-definition "definition for ~a not found" name)))
-      
-      ; passwords = str (i.e. path to a file)
-      
-      (define build-path-maybe-expression->file-name caddr)
-      
-      ; main
-      (choose-configuration-file)))
+             (configuration-table-default-host old)
+             (configuration-table-virtual-hosts old)))))
   
-  (define servlet (servlet-maker default-configuration-table-path)))
+  ; send-exn : tst -> doesn't
+  (define (send-exn exn)
+    (send/back (exception-error-page exn)))
+  
+  ; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a))
+  (define (reverse-assoc x lst)
+    (cond
+      [(null? lst) #f]
+      [else (if (equal? x (cdar lst))
+                (car lst)
+                (reverse-assoc x (cdr lst)))]))
+  
+  ; add-virtual-host : configuration-table (listof str) -> configuration-table
+  (define (add-virtual-host conf existing-prefixes)
+    (update-hosts conf (cons (cons "my-host.my-domain.org"
+                                   (configuration-table-default-host conf))
+                             (configuration-table-virtual-hosts conf))))
+  
+  ; update-hosts : configuration-table (listof (cons str host-table))
+  (define (update-hosts conf new-hosts)
+    (make-configuration-table
+     (configuration-table-port conf)
+     (configuration-table-max-waiting conf)
+     (configuration-table-initial-connection-timeout conf)
+     (configuration-table-default-host conf)
+     new-hosts))
+  
+  ; delete-hosts : configuration-table (listof str) -> configuration-table
+  ; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
+  (define (delete-hosts conf to-delete)
+    ; the if is not needed, it just avoids some work
+    (if (null? to-delete)
+        conf
+        (update-hosts
+         conf
+         (drop (configuration-table-virtual-hosts conf) to-delete))))
+  
+  ; drop : (listof a) (listof str) -> (listof a)
+  ; pre: (apply < to-delete)
+  ; to delete the entries in to-filter indexed by to-delete
+  (define (drop to-filter to-delete)
+    (let loop ([to-filter to-filter] [to-delete (map string->number to-delete)] [i 0])
+      (cond
+        [(null? to-delete) to-filter]
+        [else (if (= i (car to-delete))
+                  (loop (cdr to-filter) (cdr to-delete) (add1 i))
+                  (cons (car to-filter) (loop (cdr to-filter) to-delete (add1 i))))])))
+  
+  ; configure-hosts : configuration-table (U #f nat) -> configuration-table
+  ; n is either the virtual host number or #f for the default virtual host
+  (define (configure-hosts old n)
+    (if n
+        (update-hosts old
+                      ; more here - consider restructuring this map.  Perhaps it is fine.
+                      ; Perhaps it should short circuit.  Perhaps the number of virtual hosts
+                      ; is small so it doesn't matter. Perhaps that is a sloppy way to think/program.
+                      ; The code is really a functional array update except it's on a list.
+                      (map (lambda (host this-n)
+                             (if (= n this-n)
+                                 (cons (car host) (configure-host (cdr host)))
+                                 host))
+                           (configuration-table-virtual-hosts old)
+                           (build-list (length (configuration-table-virtual-hosts old)) (lambda (x) x))))
+        (make-configuration-table
+         (configuration-table-port old)
+         (configuration-table-max-waiting old)
+         (configuration-table-initial-connection-timeout old)
+         (configure-host (configuration-table-default-host old))
+         (configuration-table-virtual-hosts old))))
+  
+  ; configure-host : host-table -> host-table
+  (define (configure-host old)
+    (let* ([bindings (interact (request-new-host-table old))]
+           [new (update-host-table old bindings)])
+      (when (assq 'edit-passwords bindings)
+        (let* ([paths (host-table-paths new)]
+               [password-path
+                ;; build-path-unless-absolute is defined in configuration.ss
+                (build-path-unless-absolute
+                 (build-path-unless-absolute web-base (paths-host-base paths))
+                 (paths-passwords paths))])
+          (unless (file-exists? password-path)
+            (write-to-file password-path ''()))
+          (configure-passwords password-path)))
+      new))
+  
+  (define restart-message
+    `((h3 (font ([color "red"]) "Restart the Web server to use the new settings."))))
+  
+  ; request-new-configuration-table : configuration-table configuration-table -> str -> html
+  (define (request-new-configuration-table old orig)
+    (build-suspender
+     '("PLT Web Server Configuration")
+     `((h1 "PLT Web Server Configuration Management")
+       ,web-server-icon
+       "copyright 2001 by Paul Graunke and PLT"
+       (hr)
+       (h2 "Basic Configuration")
+       (table
+        ,(make-tr-num "Port" 'port (configuration-table-port old))
+        ,(make-tr-num "Maximum Waiting Connections"
+                      'waiting (configuration-table-max-waiting old))
+        ,(make-tr-num "Initial Connection Timeout (seconds)" 'time-initial
+                      (configuration-table-initial-connection-timeout old)))
+       (hr)
+       (h2 "Host Name Configuration")
+       (p "The Web server accepts requests on behalf of multiple " (em "hosts")
+          " each corresponding to a domain name."
+          " The table below maps domain names to host specific configurations.")
+       (table ([width "50%"])
+              (tr (th ([align "left"]) "Name") ;(th "Host configuration path")
+                  (th "Host Directory")
+                  (th nbsp)
+                  (th nbsp))
+              (tr (td ,"Default Host")
+                  (td ,(make-field-size "text" 'default-host-root
+                                        (table->host-root (configuration-table-default-host old))
+                                        WIDE))
+                  (td ([align "center"])
+                      (input ([type "submit"] [name "default"] [value ,edit-host-button-name])))
+                  (td nbsp))
+              ,@(map (lambda (host n)
+                       `(tr (td ,(make-field "text" 'host-regexps (car host)))
+                            (td ,(make-field-size "text" 'host-roots (table->host-root (cdr host)) WIDE))
+                            (td ([align "center"])
+                                (input ([type "submit"] [name ,n] [value ,edit-host-button-name])))
+                            (td ([align "center"])
+                                (input ([type "submit"] [name ,n] [value "Delete"])))))
+                     (configuration-table-virtual-hosts old)
+                     (build-list (length (configuration-table-virtual-hosts old)) number->string))
+              (tr (td (input ([type "submit"] [name "add-host"] [value "Add Host"])))
+                  (td nbsp); (input ([type "submit"] [name "configure"] [value "Delete"]))
+                  ;(td (input ([type "submit"] [name "edit-host-details"] [value "Edit"])))
+                  (td nbsp)))
+       (hr)
+       (table ([width "90%"])
+              ,@(if (equal? old orig) ; This only tests eq? because structures are more opaque now.
+                    null
+                    `((tr (td ,@restart-message))))
+              (tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"])))))
+       (hr)
+       ,footer)))
+  
+  ; table->host-root : host-table -> str
+  (define (table->host-root t)
+    (path->string (build-path-unless-absolute web-base (paths-host-base (host-table-paths t)))))
+  
+  ; gen-make-tr : nat -> xexpr sym str [xexpr ...] -> xexpr
+  (define (gen-make-tr size-n)
+    (let ([size-str (number->string size-n)])
+      (lambda (label tag default-text . extra-tds)
+        `(tr (td (a ([href ,(format "/~a/terms/~a.html" doc-dir tag)]) ,label))
+             (td ,(make-field-size "text" tag (format "~a" default-text) size-str))
+             . ,extra-tds))))
+  
+  (define make-tr-num (gen-make-tr 20))
+  
+  (define make-tr-str (gen-make-tr 70))
+  
+  ; make-field : str sym str -> xexpr
+  (define (make-field type label value)
+    (make-field-size type label value "30"))
+  
+  ; make-field-size : str sym str str -> xexpr
+  (define (make-field-size type label value size)
+    `(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size])))
+  
+  ; update-configuration : configuration-table bindings -> configuration-table
+  (define (update-configuration old bindings)
+    (let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path
+      (make-configuration-table
+       (string->nat (extract-binding/single 'port bindings))
+       (string->nat (extract-binding/single 'waiting bindings))
+       (string->num (extract-binding/single 'time-initial bindings))
+       (update-host-root (configuration-table-default-host old)
+                         (ubp (build-path (extract-binding/single 'default-host-root bindings))))
+       (map (lambda (h root pattern)
+              (cons pattern (update-host-root (cdr h) (ubp (build-path root)))))
+            (configuration-table-virtual-hosts old)
+            (extract-bindings 'host-roots bindings)
+            (extract-bindings 'host-regexps bindings)))))
+  
+  ; update-host-root : host-table str -> host-table
+  (define (update-host-root host new-root)
+    (host-table<-paths host (paths<-host-base (host-table-paths host) new-root)))
+  
+  ; host-table<-paths : host-table paths -> host-table
+  ; more here - create these silly functions automatically from def-struct macro
+  (define (host-table<-paths host paths)
+    (make-host-table
+     (host-table-indices host)
+     (host-table-log-format host)
+     (host-table-messages host)
+     (host-table-timeouts host)
+     paths))
+  
+  ; paths<-host-base : paths str -> paths
+  ; more here - create these silly functions automatically from def-struct macro
+  (define (paths<-host-base paths host-base)
+    (make-paths (paths-conf paths)
+                host-base
+                (paths-log paths)
+                (paths-htdocs paths)
+                (paths-servlet paths)
+                (paths-mime-types paths)
+                (paths-passwords paths)))
+  
+  ; string->num : str -> nat
+  (define (string->num str)
+    (or (string->number str) (error 'string->nat "~s is not a number" str)))
+  
+  ; string->nat : str -> nat
+  (define (string->nat str)
+    (let ([n (string->number str)])
+      (if (and n (integer? n) (exact? n) (>= n 0))
+          n
+          (error 'string->nat "~s is not exactly a natural number" str))))
+  
+  ; request-new-host-table : host-table -> str -> response
+  (define (request-new-host-table old)
+    (let* ([timeouts (host-table-timeouts old)]
+           [paths (host-table-paths old)]
+           [m (host-table-messages old)]
+           [host-root (build-path-unless-absolute web-base (paths-host-base paths))]
+           [conf (build-path-unless-absolute host-root (paths-conf paths))])
+      (build-suspender
+       '("Configure Host")
+       `((h1 "PLT Web Server Host configuration")
+         (input ([type "submit"] [value "Save Configuration"]))
+         (hr)
+         (table
+          (tr (th ([colspan "2"]) "Paths"))
+          ,(make-tr-str "Log file"
+                        'path-log (build-path-unless-absolute host-root (paths-log paths)))
+          ,(make-tr-str "Web document root"
+                        'path-htdocs (build-path-unless-absolute host-root (paths-htdocs paths)))
+          ,(make-tr-str "Servlet root"
+                        'path-servlet (build-path-unless-absolute host-root (paths-servlet paths)))
+          ,(make-tr-str "MIME Types"
+                        'path-mime-types (build-path-unless-absolute host-root (paths-mime-types paths)))
+          ,(make-tr-str "Password File"
+                        'path-password (build-path-unless-absolute host-root (paths-passwords paths)))
+          (tr (td ([colspan "2"])
+                  ,(make-field "submit" 'edit-passwords "Edit Passwords")))
+          (tr (td ([colspan "2"]) (hr)))
+          (tr (th ([colspan "2"]) "Message Paths"))
+          ,(make-tr-str "Servlet error" 'path-servlet-message
+                        (build-path-unless-absolute conf (messages-servlet m)))
+          ,(make-tr-str "Access Denied" 'path-access-message
+                        (build-path-unless-absolute conf (messages-authentication m)))
+          ,(make-tr-str "Servlet cache refreshed" 'servlet-refresh-message
+                        (build-path-unless-absolute conf (messages-servlets-refreshed m)))
+          ,(make-tr-str "Password cache refreshed" 'password-refresh-message
+                        (build-path-unless-absolute conf (messages-passwords-refreshed m)))
+          ,(make-tr-str "File not found" 'path-not-found-message
+                        (build-path-unless-absolute conf (messages-file-not-found m)))
+          ,(make-tr-str "Protocol error" 'path-protocol-message
+                        (build-path-unless-absolute conf (messages-protocol m)))
+          ,(make-tr-str "Collect garbage" 'path-collect-garbage-message
+                        (build-path-unless-absolute conf (messages-collect-garbage m)))
+          (tr (td ([colspan "2"]) (hr)))
+          (tr (th ([colspan "2"]) "Timeout Seconds"))
+          ,(make-tr-num "Default Servlet" 'time-default-servlet (timeouts-default-servlet timeouts))
+          ,(make-tr-num "Password" 'time-password (timeouts-password timeouts))
+          ,(make-tr-num "Servlet Connection" 'time-servlet-connection (timeouts-servlet-connection timeouts))
+          ,(make-tr-num "per Byte When Transfering Files" 'time-file-per-byte (timeouts-file-per-byte timeouts))
+          ,(make-tr-num "Base When Transfering Files" 'time-file-base (timeouts-file-base timeouts)))
+         (hr)
+         (input ([type "submit"] [value "Save Configuration"]))
+         ,footer))))
+  
+  ; update-host-table : host-table (listof (cons sym str)) -> host-table
+  (define (update-host-table old bindings)
+    (let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))]
+           [paths (host-table-paths old)]
+           [host-root (paths-host-base paths)]
+           [expanded-host-root (build-path-unless-absolute web-base host-root)]
+           [conf (build-path-unless-absolute expanded-host-root (paths-conf paths))]
+           [ubp (un-build-path expanded-host-root)]
+           [eb-host-root (lambda (tag) (ubp (eb tag)))]
+           [ubp-conf (un-build-path conf)]
+           [eb-conf (lambda (tag) (ubp-conf (eb tag)))])
+      (make-host-table
+       (host-table-indices old)
+       (host-table-log-format old)
+       (apply make-messages
+              (map eb-conf '(path-servlet-message path-access-message servlet-refresh-message password-refresh-message path-not-found-message path-protocol-message path-collect-garbage-message)))
+       (apply make-timeouts
+              (map (lambda (tag) (string->number (extract-binding/single tag bindings)))
+                   '(time-default-servlet time-password time-servlet-connection time-file-per-byte time-file-base)))
+       (let ([old-paths (host-table-paths old)])
+         (apply make-paths
+                (paths-conf old-paths)
+                ((un-build-path web-base)
+                 (build-path (paths-host-base old-paths)))
+                (map eb-host-root '(path-log path-htdocs path-servlet path-mime-types path-password)))))))
+  
+  ; un-build-path : path -> path -> string
+  ; (GregP) Theory: this should return a string not a path so that the result can be
+  ;                 written to the configuration file.
+  (define (un-build-path possible-base)
+    (let ([base-list (path->list possible-base)])
+      (lambda (path)
+        (let ([path-list (path->list path)])
+          (cond
+            [(suffix base-list path-list)
+             => (lambda (x) (path->string (apply build-path x)))]
+            [else
+             (path->string path)])))))
+  
+  ; suffix : (listof a) (listof a) -> (U #f (listof a))
+  ; to return the extra elements in b after removing all elements from a in order
+  (define (suffix a b)
+    (cond
+      [(null? a) (if (null? b) #f b)]
+      [else (cond
+              [(null? b) #f]
+              [else (and (equal? (car a) (car b))
+                         (suffix (cdr a) (cdr b)))])]))
+  
+  ; Password Configuration
+  
+  ; configure-passwords : path -> void
+  (define (configure-passwords password-path)
+    (edit-passwords
+     password-path
+     (if (file-exists? password-path)
+         (call-with-input-file password-path read-passwords)
+         null)))
+  
+  ; edit-passwords : path passwords -> passwords
+  (define (edit-passwords which-one passwords)
+    (let* ([bindings (interact (password-updates which-one passwords))]
+           [to-deactivate (extract-bindings 'deactivate bindings)]
+           [again
+            (lambda (new-passwords)
+              (write-to-file which-one (format-passwords new-passwords))
+              (edit-passwords which-one new-passwords))])
+      (cond
+        [(assq 'edit bindings)
+         => (lambda (edit)
+              (again (drop (map (let ([to-edit (string->number (cdr edit))])
+                                  (lambda (r n)
+                                    (if (= to-edit n)
+                                        (edit-realm r)
+                                        r)))
+                                passwords
+                                (build-list (length passwords) (lambda (x) x)))
+                           to-deactivate)))]
+        [(assq 'add bindings)
+         (again (cons (make-realm "new realm" "" null)
+                      (drop passwords to-deactivate)))]
+        [else (drop passwords to-deactivate)])))
+  
+  ; password-updates : path passwords -> request
+  (define (password-updates which-one passwords)
+    (let ([which-one (path->string which-one)])
+      (build-suspender
+       `("Updating Passwords for " ,which-one)
+       `((h1 "Updating Passwords for ")
+         (h3 ,which-one)
+         (h2 "You may wish to " (font ([color "red"]) "backup") " this password file.")
+         (p "Each authentication " (em "realm") " password protects URLs that match a pattern. "
+            "Choose a realm to edit below:")
+         (table
+          (tr (th "Realm Name") (th "Delete") (th "Edit"))
+          . ,(map (lambda (realm n)
+                    `(tr (td ,(realm-name realm))
+                         (td ,(make-field "checkbox" 'deactivate n))
+                         (td ,(make-field "radio" 'edit n))))
+                  passwords
+                  (build-list (length passwords) number->string)))
+         ,(make-field "submit" 'add "Add Realm")
+         ,(make-field "submit" 'edit-button "Edit")
+         ,footer))))
+  
+  ; edit-realm : realm -> realm
+  (define (edit-realm realm)
+    (let* ([bindings (interact (realm-updates realm))]
+           [new-name (extract-binding/single 'realm-name bindings)]
+           [new-pattern (extract-binding/single 'realm-pattern bindings)]
+           [new-allowed
+            (drop (map (lambda (u p) (make-user-pass (string->symbol u) p))
+                       (extract-bindings 'user bindings)
+                       (extract-bindings 'pass bindings))
+                  (extract-bindings 'deactivate bindings))])
+      ; more here - check something?  Everything is a string or symbol, though.
+      (cond
+        [(assq 'add-user bindings)
+         (edit-realm (make-realm new-name new-pattern
+                                 (cons (make-user-pass 'ptg "Scheme-is-cool!") new-allowed)))]
+        [(assq 'update bindings)
+         (make-realm new-name new-pattern new-allowed)]
+        [else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)])))
+  
+  ; realm-updates : realm -> request
+  (define (realm-updates realm)
+    (build-suspender
+     `("Update Authentication Realm " ,(realm-name realm))
+     `((h1 "Update Authentication Realm")
+       (table
+        ,(make-tr-str "Realm Name" 'realm-name (realm-name realm))
+        ,(make-tr-str "Protected URL Path Pattern" 'realm-pattern (realm-pattern realm)))
+       (hr)
+       (table
+        (tr (th "User Name") (th "Password") (th "Delete"))
+        . ,(map (lambda (x n)
+                  `(tr (td ,(make-field "text" 'user (symbol->string (user-pass-user x))))
+                       (td ,(make-field "text" 'pass (user-pass-pass x)))
+                       (td ,(make-field "checkbox" 'deactivate n))))
+                (realm-allowed realm)
+                (build-list (length (realm-allowed realm)) number->string)))
+       (input ([type "submit"] [name "add-user"] [value "Add User"]))
+       (input ([type "submit"] [name "update"] [value "Update Realm"]))
+       ,footer)))
+  
+  ; read-passwords : iport -> passwords
+  ; only works if the file starts with (quote ...)
+  (define (read-passwords in)
+    (let ([raw (read in)])
+      (unless (and (pair? raw) (eq? 'quote (car raw))
+                   (null? (cddr raw)))
+        (error 'read-passwords "The password file must be quoted to use the configuration tool."))
+      (map (lambda (raw-realm)
+             ; more here - error checking
+             (make-realm (car raw-realm)
+                         (cadr raw-realm)
+                         (map (lambda (x) (make-user-pass (car x) (cadr x)))
+                              (cddr raw-realm))))
+           (cadr raw))))
+  
+  ; format-passwords : passwords -> s-expr
+  (define (format-passwords passwords)
+    (list 'quote
+          (map (lambda (r)
+                 (list* (realm-name r)
+                        (realm-pattern r)
+                        (map (lambda (x)
+                               (list (user-pass-user x) (user-pass-pass x)))
+                             (realm-allowed r))))
+               passwords)))
+  
+  ; Little Helpers
+  
+  ; initialization-error-page : request -> response
+  (define (initialization-error-page initial-request)
+    `(html (head (title "Web Server Configuration Program Invocation Error"))
+           (body ([bgcolor "white"])
+                 (p "Please direct your browser directly to the "
+                    (a ([href ,(url->string (request-uri initial-request))]) "configuration program,")
+                    " not through another URL.")
+                 ,footer)))
+  
+  ; done-page : html
+  (define done-page
+    ; more-here - consider adding more useful information
+    `(html (head (title "done"))
+           (body ([bgcolor "white"])
+                 (h2 "Configuration Saved.")
+                 (p "Click your browser's back button to continue configuring the server.")
+                 ,footer)))
+  
+  ; exception-error-page : TST -> html
+  (define (exception-error-page exn)
+    `(html (head (title "Error"))
+           (body ([bgcolor "white"])
+                 (p "Servlet exception: "
+                    (pre ,(exn->string exn)))
+                 ,footer)))
+  
+  (define must-select-host-page
+    `(html (head (title "Web Server Configuration Error"))
+           (body ([bgcolor "white"])
+                 (p "Please select which host to edit before clicking the Edit button.")
+                 ,footer)))
+  
+  ; io
+  
+  ; read-configuration : path -> configuration-table
+  (define (read-configuration configuration-path)
+    (parse-configuration-table (call-with-input-file configuration-path read)))
+  
+  ; write-configuration : configuration-table path -> void
+  ; writes out the new configuration file and
+  ; also copies the configure.ss servlet to the default-host's servlet directory
+  (define (write-configuration new configuration-path)
+    (ensure-configuration-servlet configuration-path (configuration-table-default-host new))
+    (ensure-configuration-paths new)
+    (write-configuration-table new configuration-path))
+  
+  ; ensure-configuration-servlet : path host-table -> void
+  (define (ensure-configuration-servlet configuration-path host)
+    (let* ([paths (host-table-paths host)]
+           [root (build-path-unless-absolute web-base
+                                             (paths-host-base paths))]
+           [servlets-path
+            (build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
+      (ensure-config-servlet configuration-path servlets-path)
+      (let ([defaults (build-path "Defaults")])
+        (ensure* (collection-path "web-server" "default-web-root" "htdocs")
+                 (build-path-unless-absolute root (paths-htdocs paths))
+                 defaults))))
+  
+  ; ensure-configuration-paths : configuration-table -> void
+  ; to ensure that all the referenced config files exist for an entire configuration
+  (define (ensure-configuration-paths configuration)
+    (ensure-host-configuration (configuration-table-default-host configuration))
+    (for-each (lambda (x) (ensure-host-configuration (cdr x)))
+              (configuration-table-virtual-hosts configuration)))
+  
+  ; ensure-host-configuration : host-table -> void
+  ; to ensure that all the referenced config files exist for a virtual host
+  (define (ensure-host-configuration host)
+    (let* ([paths (host-table-paths host)]
+           [host-base (build-path-unless-absolute web-base (paths-host-base paths))]
+           [conf (build-path-unless-absolute host-base (paths-conf paths))]
+           [log (build-path-unless-absolute host-base (paths-log paths))])
+      ; skip passwords since a missing file is an okay default
+      (ensure-directory-shallow conf)
+      (ensure-directory-shallow host-base)
+      ;(ensure-file log ...) ; empty log file is okay
+      (ensure-directory-shallow (build-path-unless-absolute host-base (paths-htdocs paths)))
+      (ensure-directory-shallow (build-path-unless-absolute host-base (paths-servlet paths)))
+      (let* ([messages (host-table-messages host)]
+             ; more here maybe - check default config file instead? maybe not
+             [from-conf (collection-path "web-server" "default-web-root" "conf")]
+             [copy-conf
+              (lambda (from to)
+                (let ([to-path (build-path-unless-absolute conf to)])
+                  ; more here - check existance of from path?
+                  (copy-file* (build-path from-conf from) to-path)))])
+        (copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
+        (copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))
+        (copy-conf "forbidden.html" (messages-authentication messages))
+        (copy-conf "protocol-error.html" (messages-protocol messages))
+        (copy-conf "not-found.html" (messages-file-not-found messages))
+        (copy-conf "servlet-error.html" (messages-servlet messages))
+        (copy-conf "collect-garbage.html" (messages-collect-garbage messages)))))
+  
+  ; ensure-file : path path path -> void
+  ; to copy (build-path from name) to (build-path to name), creating directories as
+  ; needed if the latter does not already exist.
+  (define (ensure-file from to name)
+    (let ([to (simplify-path to)])
+      (ensure-directory-shallow to)
+      (let ([to-path (build-path to name)])
+        (unless (file-exists? to-path)
+          (copy-file (build-path from name) to-path)))))
+  
+  ; copy-file* : str str -> void
+  (define (copy-file* from-path to-path)
+    (unless (file-exists? to-path)
+      (let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)])
+        (ensure-directory-shallow to-path-base))
+      (copy-file from-path to-path)))
+  
+  ; ensure* : path path path -> void
+  ;; GregP: Don't know what the heck this does (thanks Paul)
+  ;;        but the first two arguments are now paths.
+  (define (ensure* from to name)
+    (ensure-directory-shallow to)
+    (let ([p (build-path from name)])
+      (cond
+        [(directory-exists? p)
+         (unless (member (path->string name) '("CVS" ".svn")) ; yuck
+           (let ([dest (build-path to name)])
+             (ensure-directory-shallow dest)
+             (for-each (lambda (x) (ensure* p dest x))
+                       (directory-list p))))]
+        [(file-exists? p)
+         (ensure-file from to name)])))
+  
+  ; ensure-directory-shallow : path -> void
+  (define (ensure-directory-shallow to)
+    (unless (directory-exists? to)
+      ; race condition - someone else could make the directory
+      (make-directory* to)))
+  
+  ; ensure-config-servlet : str path -> void
+  ; to create, if necessary, a stub configuration servlet that includes the main configuration servlet
+  ; at the desired location in a new web tree
+  (define (ensure-config-servlet configuration-path servlets-path)
+    (ensure-directory-shallow servlets-path)
+    (let ([file-path (build-path servlets-path CONFIGURE-SERVLET-NAME)])
+      (unless (file-exists? file-path) ; more here - check that it's a well formed servlet?
+        (call-with-output-file
+            file-path
+          (lambda (out)
+            (pretty-print
+             `(module ,CONFIGURE-SERVLET-NAME mzscheme
+                (require (lib ,CONFIGURE-SERVLET-NAME "web-server" "private"))
+                (provide (all-from (lib ,CONFIGURE-SERVLET-NAME "web-server" "private")))
+                (set-config-path! ,(path->string configuration-path)))
+             out)
+            (newline out))))))
+  
+  ; extract-definition : sym (listof s-expr) -> s-expr
+  ; to return the rhs from (def name rhs) not (def (name . args) body)
+  (define (extract-definition name defs)
+    (or (ormap (lambda (def)
+                 (and (pair? def) (eq? 'define (car def))
+                      (pair? (cdr def)) (eq? name (cadr def))
+                      (pair? (cddr def))
+                      (caddr def)))
+               defs)
+        (error 'extract-definition "definition for ~a not found" name)))
+  
+  ; passwords = str (i.e. path to a file)
+  
+  (define build-path-maybe-expression->file-name caddr)
+  
+  ; main
+  (define (start initial-request)
+    (error-print-width 800) ; 10-ish lines
+    (check-ip-address initial-request)
+    (choose-configuration-file)))
\ No newline at end of file
diff --git a/collects/web-server/sig.ss b/collects/web-server/sig.ss
index f5d92c4e22..136bb5a55f 100644
--- a/collects/web-server/sig.ss
+++ b/collects/web-server/sig.ss
@@ -3,13 +3,7 @@
   (require "private/dispatch-server-sig.ss")
   (provide ; XXX contract signature
    (rename dispatch-server^ web-server^) 
-   servlet^ web-config^ web-config/pervasive^ web-config/local^)
-
-  #;(define-signature web-server^
-    ((open dispatch-server^)))
-  
-  (define-signature servlet^
-    (initial-request send/suspend send/finish send/back send/forward adjust-timeout!))
+   web-config^ web-config/pervasive^ web-config/local^)  
 
   ; more here - rename
   (define-signature web-config/pervasive^