Arjun

svn: r7243

collects/web-server/servlet-env.ss

@@ -1,14 +1,14 @@
 (module servlet-env mzscheme
   (require (prefix net: (lib "sendurl.ss" "net"))
-           (lib "unit.ss"))
+           (lib "list.ss"))
   (require "web-server.ss"
            "configuration/configuration-table.ss"
-           "web-config-unit.ss"
-           "web-config-sig.ss"
            "private/util.ss"
            "managers/timeouts.ss"
            "private/servlet.ss"
-           "private/cache-table.ss")
+           "configuration/namespace.ss"
+           "private/cache-table.ss"           
+           (prefix servlets: "dispatchers/dispatch-servlets.ss"))
   (require "servlet.ss")
   (provide (rename on-web:syntax on-web)
            send-url
@@ -30,15 +30,17 @@
                   "servlets/standalone.ss")))]))
   
   (define (on-web servlet-expr the-port the-path)
-    (let* ([standalone-url
+    (let*-values
+        ([(standalone-url)
           (format "http://localhost:~a/~a" the-port the-path)]
-           [final-value
+         [(final-value)
           (void)]
-           [final-conn
+         [(final-conn)
           (void)]
-           [sema
+         [(sema)
           (make-semaphore 0)]
-           [new-servlet
+         [(make-servlet-namespace) (make-make-servlet-namespace)]
+         [(new-servlet)
           (lambda (initial-request)
             (let ([v (servlet-expr initial-request)])
               (set! final-value v)
@@ -47,22 +49,19 @@
                   v
                   `(html (head (title "Servlet has ended."))
                          (body (p "This servlet has ended, please return to the interaction window."))))))]
-           [shutdown-server
-            (serve/web-config@ (build-standalone-servlet-configuration the-port the-path new-servlet))])
-      ((send-url) standalone-url #t)
-      ; Wait for final call
-      (semaphore-wait sema)
-      ; XXX: Find a way to wait for final HTML to be sent
-      ; Shutdown the server
-      (shutdown-server)
-      final-value))
-  
-  (define (build-standalone-servlet-configuration the-port the-path the-servlet)
-    (let ([basic-configuration@ (configuration-table->web-config@ default-configuration-table-path)]
-          [the-scripts (make-cache-table)])
-      (define-values/invoke-unit basic-configuration@ 
-        (import) 
-        (export (prefix i: web-config^)))
+         [(the-scripts) (make-cache-table)]
+         [(clear-cache! servlet-dispatch)
+          (servlets:make (box the-scripts)
+                         #:make-servlet-namespace make-servlet-namespace
+                         #:url->path
+                         (lambda _
+                           (values (build-path (directory-part default-configuration-table-path)
+                                         "default-web-root" "."
+                                         the-path)
+                                   empty)))]
+         [(shutdown-server)
+          (serve #:dispatch servlet-dispatch
+                 #:port 9999)])
       (cache-table-lookup! the-scripts
                            (string->symbol
                             (path->string
@@ -71,20 +70,17 @@
                                          the-path)))
                            (lambda ()
                              (make-servlet (make-custodian)
-                                           (i:make-servlet-namespace)
+                                           (make-servlet-namespace)
                                            (create-timeout-manager
                                             (lambda (request)
                                               `(html (head "Return to the interaction window.")
                                                      (body (p "Return to the interaction window."))))
                                             30 30)
-                                           the-servlet)))
-      (unit
-        (import)
-        (export web-config^)
-        (define port the-port)
-        (define max-waiting i:max-waiting)
-        (define listen-ip i:listen-ip)
-        (define initial-connection-timeout i:initial-connection-timeout)
-        (define virtual-hosts i:virtual-hosts)
-        (define scripts (box the-scripts))
-        (define make-servlet-namespace i:make-servlet-namespace)))))
+                                           new-servlet)))
+      ((send-url) standalone-url #t)
+      ; Wait for final call
+      (semaphore-wait sema)
+      ; XXX: Find a way to wait for final HTML to be sent
+      ; Shutdown the server
+      (shutdown-server)
+      final-value)))