From 8aa62e22b25f7e7b9f555a332ca82073dcc75dd3 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 29 Dec 2009 16:02:59 +0000
Subject: [PATCH] * Move namespace specs back to main code, and pass them
 through a   `#:namespace' keyword * More robust error handler -- use the url
 that initiated the   interaction

svn: r17428
---
 collects/handin-server/run-servlet.ss       | 54 ++++++++++++---------
 collects/handin-server/web-status-server.ss |  5 ++
 2 files changed, 35 insertions(+), 24 deletions(-)

diff --git a/collects/handin-server/run-servlet.ss b/collects/handin-server/run-servlet.ss
index 972ade0f6b..deabbe1148 100644
--- a/collects/handin-server/run-servlet.ss
+++ b/collects/handin-server/run-servlet.ss
@@ -14,41 +14,47 @@
          (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
          (prefix-in files: web-server/dispatchers/dispatch-files)
          (prefix-in log: web-server/dispatchers/dispatch-log)
+         web-server/http/request-structs
+         net/url
          net/tcp-sig
          net/ssl-tcp-unit)
 
-(define ((send-error msg) req)
-  `(html (head (meta [(http-equiv "refresh") (content "3;URL=/")])
-               (title ,msg))
-         (body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds.")))
-
 (provide run-servlet)
 (define (run-servlet dispatcher port server-dir
+                     #:namespace [namespace '()]
                      #:log-file [log-file #f])
+  (define ((send-error msg to) req)
+    (let ([to (to)])
+      `(html (head (meta ([http-equiv "refresh"]
+                          [content ,(format "3;URL=~a" to)]))
+                   (title ,msg))
+             (body ,msg "; " (a ([href ,to]) "restarting") " in 3 seconds."))))
+  (define tcp@
+    (let ()
+      (define-unit-binding ssl-tcp@
+        (make-ssl-tcp@ (build-path server-dir "server-cert.pem")
+                       (build-path server-dir "private-key.pem")
+                       #f #f #f #f #f)
+        (import) (export tcp^))
+      ssl-tcp@))
   (serve
    #:port port #:listen-ip #f
-   #:tcp@ (let ()
-            (define-unit-binding ssl-tcp@
-              (make-ssl-tcp@ (build-path server-dir "server-cert.pem")
-                             (build-path server-dir "private-key.pem")
-                             #f #f #f #f #f)
-              (import) (export tcp^))
-            ssl-tcp@)
+   #:tcp@ tcp@
    #:dispatch
    (sequencer:make
     (and log-file (log:make #:format (log:log-format->format 'apache-default)
                             #:log-path log-file))
-    (dispatch/servlet
-     dispatcher
-     #:regexp #rx""
-     #:namespace '(handin-server/private/md5
-                   handin-server/private/logger
-                   handin-server/private/config
-                   handin-server/private/hooker
-                   handin-server/private/reloadable)
-     #:current-directory server-dir
-     #:manager (make-threshold-LRU-manager
-                (send-error "Your session has expired") (* 12 1024 1024)))
+    (let ([init-path (make-parameter "/")])
+      (dispatch/servlet
+       (lambda (req)
+         (init-path (url->string (request-uri req)))
+         (dispatcher req))
+       #:regexp #rx"^/(?:/|$)"
+       #:namespace namespace
+       #:current-directory server-dir
+       #:manager (make-threshold-LRU-manager
+                  (send-error "Your session has expired" init-path)
+                  (* 12 1024 1024))))
     (files:make
      #:url->path (fsmap:make-url->path (build-path server-dir "htdocs")))
-    (lift:make (send-error "File not found")))))
+    (lift:make (send-error "File not found" (lambda () "/"))))))
diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss
index 131b6c84fe..2ac4c0534e 100644
--- a/collects/handin-server/web-status-server.ss
+++ b/collects/handin-server/web-status-server.ss
@@ -259,5 +259,10 @@
               (log-line "*** starting web server")
               (parameterize ([error-print-context-length 0])
                 (run-servlet dispatcher p server-dir
+                             #:namespace '(handin-server/private/md5
+                                           handin-server/private/logger
+                                           handin-server/private/config
+                                           handin-server/private/hooker
+                                           handin-server/private/reloadable)
                              #:log-file (get-conf 'web-log-file))))]
         [else void]))