pr 8028 and 8029

svn: r3347

collects/web-server/bindings.ss

@@ -0,0 +1,27 @@
+(module bindings mzscheme
+  (require (lib "list.ss"))
+  (provide extract-binding/single
+           extract-bindings
+           exists-binding?)
+                
+  ; extract-binding/single : sym (listof (cons str str)) -> str
+  (define (extract-binding/single name bindings)
+    (define lst (extract-bindings name bindings))
+    (cond
+      [(empty? lst)
+       (error 'extract-binding/single "~e not found in ~e" name bindings)]
+      [(empty? (rest lst))
+       (first lst)]
+      [else 
+       (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)]))
+  
+  ; extract-bindings : sym (listof (cons str str)) -> (listof str)
+  (define (extract-bindings name bindings)
+    (map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
+  
+  ; exists-binding? : sym (listof (cons sym str)) -> bool
+  ; for checkboxes
+  (define (exists-binding? name bindings)
+    (if (assq name bindings)
+        #t
+        #f)))

collects/web-server/configuration.ss

@@ -21,6 +21,17 @@
    [load-configuration (path? . -> . unit/sig?)]
    [load-developer-configuration (path? . -> . unit/sig?)])
   
+  (provide error-response
+           servlet-loading-responder
+           gen-servlet-not-found
+           gen-servlet-responder
+           gen-servlets-refreshed
+           gen-passwords-refreshed
+           gen-authentication-responder
+           gen-protocol-responder
+           gen-file-not-found-responder
+           gen-collect-garbage-responder)
+  
   (define default-configuration-table-path
     (build-path (collection-path "web-server") "configuration-table"))
   

collects/web-server/dispatchers/dispatch-files.ss

@@ -1,27 +1,35 @@
 (module dispatch-files mzscheme
   (require (lib "url.ss" "net")
            (lib "xml.ss" "xml")
+           (lib "kw.ss")
            (lib "list.ss"))
   (require "dispatch.ss"
+           "../configuration.ss"
            "../util.ss"
            "../mime-types.ss"
            "../response.ss")  
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define (gen-dispatcher htdocs-path mime-types-path indices file-not-found-responder)
+  (define/kw (make #:key 
-    (let ([get-mime-type (make-get-mime-type mime-types-path)])
+                   [htdocs-path "htdocs"]
+                   [mime-types-path "mime.types"]
+                   [indices (list "index.html" "index.htm")]
+                   [file-not-found-responder 
+                    (gen-file-not-found-responder "not-found.html")])
+    (define get-mime-type (make-get-mime-type mime-types-path))
     (lambda (conn req)
-      (let-values ([(uri method path) (decompose-request req)])
+      (define-values (uri method _path) (decompose-request req))
       ;; ************************************************************
       ;; ************************************************************
       ;; SERVING FILES
       
       ;; serve-file : connection symbol uri host -> void
       ;; to find the file, including searching for implicit index files, and serve it out
-        (let ([path (url-path->path htdocs-path
+      (define path 
-                                    (translate-escapes (url-path->string (url-path uri))))])
+        (url-path->path htdocs-path
+                        (translate-escapes (url-path->string (url-path uri)))))
       (cond
         [(file-exists? path)
          (output-file conn path method (get-mime-type path))]
@@ -40,7 +48,7 @@
              [else
               (output-response/method conn (file-not-found-responder uri) method)]))]
         [else
-             (output-response/method conn (file-not-found-responder uri) method)]))))))
+         (output-response/method conn (file-not-found-responder uri) method)])))
   
   ;; looks-like-directory : str -> bool
   ;; to determine if is url style path looks like it refers to a directory

collects/web-server/dispatchers/dispatch-host.ss

@@ -2,10 +2,10 @@
   (require "dispatch.ss"
            "../servlet-helpers.ss")
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define (gen-dispatcher lookup-dispatcher)
+  (define (make lookup-dispatcher)
     (lambda (conn req)
       (let* ([host (get-host (request-uri req) (request-headers/raw req))])
         ((lookup-dispatcher host) conn req)))))

collects/web-server/dispatchers/dispatch-log.ss

@@ -1,15 +1,18 @@
 (module dispatch-log mzscheme
   (require (lib "url.ss" "net")
            (lib "date.ss")
+           (lib "kw.ss")
            (lib "async-channel.ss")
            (lib "plt-match.ss"))
   (require "dispatch.ss"
            "../servlet-helpers.ss")  
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define (gen-dispatcher log-format log-path)
+  (define/kw (make #:key 
+                   [log-format 'parenthesized-default]
+                   [log-path #f])
     (if log-path
         (case log-format
           [(parenthesized-default)
@@ -34,8 +37,8 @@
   ; to produce a string that is displayed into the log file
   ; This is a kill-safe wait-less abstraction
   (define (gen-log-message log-format log-path)
-    (let* ([log-ch (make-async-channel)]
+    (define log-ch (make-async-channel))
-           [log-thread
+    (define log-thread
       (thread/suspend-to-kill
        (lambda ()
          (let loop ([log-p #f])
@@ -57,8 +60,8 @@
                                (list 'from client-ip 'to host-ip 'for (url->string uri) 'at
                                      (date->string (seconds->date (current-seconds)) #t)))
                        log-p)
-                            (loop log-p)]))))))))])
+                      (loop log-p)])))))))))
     (lambda args
-        (thread-resume log-thread)
+      (thread-resume log-thread (current-custodian))
       (async-channel-put log-ch args)
-        (void)))))
+      (void))))

collects/web-server/dispatchers/dispatch-passwords.ss

@@ -1,26 +1,31 @@
 (module dispatch-passwords mzscheme
+  (require (lib "kw.ss"))
   (require "dispatch.ss"
            (all-except "../util.ss" translate-escapes)
+           "../configuration.ss"
            "../servlet-helpers.ss"
            "../connection-manager.ss"
            "../response.ss")  
-  
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define (gen-dispatcher password-file password-connection-timeout authentication-responder passwords-refresh-responder)
+  (define/kw (make #:key
-    (let* ([password-cache (box #f)]
+                   [password-file "passwords"]
-           [reset-password-cache!
+                   [password-connection-timeout 300]
-            (lambda ()
+                   [authentication-responder 
+                    (gen-authentication-responder "forbidden.html")]
+                   [passwords-refresh-responder
+                    (gen-passwords-refreshed "passwords-refresh.html")])
+    (define password-cache (box #f))
+    (define (reset-password-cache!)
       ; more here - a malformed password file will kill the connection
-              (set-box! password-cache (read-passwords password-file)))]
+      (set-box! password-cache (read-passwords password-file)))
-           [read-password-cache
+    (define (read-password-cache)
-            (lambda ()
+      (unbox password-cache))
-              (unbox password-cache))])
     (reset-password-cache!)
     (lambda (conn req)
-        (let-values ([(uri method path) (decompose-request req)])
+      (define-values (uri method path) (decompose-request req))
       (cond
         [(access-denied? method path (request-headers/raw req) (read-password-cache))
          => (lambda (realm)
@@ -36,7 +41,7 @@
           (passwords-refresh-responder)
           method)]
         [else
-             (next-dispatcher)])))))
+         (next-dispatcher)])))
   
   ;; ****************************************
   ;; ****************************************
@@ -49,10 +54,10 @@
   ;; denied?: str sym str -> (or/c str #f)
   ;; the return string is the prompt for authentication
   (define (access-denied? method uri-str headers denied?)    
-    (let ([user-pass (extract-user-pass headers)])
+    (define user-pass (extract-user-pass headers))
     (if user-pass
         (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
-          (denied? uri-str fake-user ""))))
+        (denied? uri-str fake-user "")))
   
   (define-struct (exn:password-file exn) ())
   

collects/web-server/dispatchers/dispatch-pathprocedure.ss

@@ -3,10 +3,10 @@
            "../util.ss"
            "../response.ss")
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define ((gen-dispatcher the-path procedure) conn req)
+  (define ((make the-path procedure) conn req)
     (let-values ([(uri method path) (decompose-request req)])
       (if (string=? the-path path)
           (output-response/method

collects/web-server/dispatchers/dispatch-sequencer.ss

@@ -2,10 +2,10 @@
   (require (lib "list.ss"))
   (require "dispatch.ss")
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define ((gen-dispatcher . dispatchers) conn req)
+  (define ((make . dispatchers) conn req)
     (let loop ([dispatchers dispatchers])
       (let ([c (first dispatchers)])
         (with-handlers ([exn:dispatcher?

collects/web-server/dispatchers/dispatch-servlets.ss

@@ -1,5 +1,6 @@
 (module dispatch-servlets mzscheme
   (require (lib "url.ss" "net")
+           (lib "kw.ss")
            (lib "plt-match.ss")
            (lib "unitsig.ss"))
   (require "dispatch.ss"
@@ -8,6 +9,7 @@
            "../response.ss"
            "../servlet.ss"
            "../sig.ss"
+           "../configuration.ss"
            (all-except "../util.ss" translate-escapes)
            "../managers/manager.ss"
            "../managers/timeouts.ss"
@@ -15,14 +17,22 @@
            "../private/servlet.ss"
            "../private/cache-table.ss")  
   (provide interface-version
-           gen-dispatcher)
+           make)
   
   (define interface-version 'v1)
-  (define (gen-dispatcher config:instances config:scripts config:make-servlet-namespace
+  (define/kw (make config:instances config:scripts config:make-servlet-namespace
-                          servlet-root
+                   #:key
-                          responders-servlets-refreshed responders-servlet-loading responders-servlet
+                   [servlet-root "servlets"]
-                          responders-file-not-found
+                   [responders-servlets-refreshed
-                          timeouts-servlet-connection timeouts-default-servlet)
+                    (gen-servlets-refreshed "servlet-refresh.html")]
+                   [responders-servlet-loading
+                    servlet-loading-responder]
+                   [responders-servlet
+                    (gen-servlet-responder "servlet-error.html")]
+                   [responders-file-not-found
+                    (gen-file-not-found-responder "not-found.html")]
+                   [timeouts-servlet-connection (* 60 60 24)]
+                   [timeouts-default-servlet 30])
     ;; ************************************************************
     ;; ************************************************************
     ;; SERVING SERVLETS

collects/web-server/parse-table.ss

@@ -1,17 +1,23 @@
 (module parse-table mzscheme
-  (require (lib "match.ss")
+  (require (lib "list.ss"))
-           "configuration-table-structs.ss")
+  (require "configuration-table-structs.ss"
+           "bindings.ss")
   (provide parse-configuration-table)
   
+  (define (get-binding key bindings default)
+    (first (get-binding* key bindings (list default))))
+  
+  (define (get-binding* key bindings default)
+    (with-handlers ([exn? (lambda _ default)])
+      (extract-binding/single key bindings)))
+  
   ; parse-configuration-table : tst -> configuration-table
-  (define parse-configuration-table
+  (define (parse-configuration-table t)
-    (match-lambda
+    (define port (get-binding 'port t 80))
-     [`((port ,port)
+    (define max-waiting (get-binding 'max-waiting t 40))
-        (max-waiting ,max-waiting)
+    (define initial-connection-timeout (get-binding 'initial-connection-timeout t 30))
-        (initial-connection-timeout ,initial-connection-timeout)
+    (define default-host-table (get-binding* 'default-host-table t `()))
-        (default-host-table
+    (define virtual-host-table (get-binding* 'virtual-host-table t `()))
-         ,default-host-table)
-        (virtual-host-table . ,virtual-host-table))
     (if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
              ; more here - list? isn't really picky enough
              (list? virtual-host-table))
@@ -24,37 +30,35 @@
                     (error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
               virtual-host-table))
         (error 'parse-configuration-table "invalid configuration values ~s"
-                 (list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))]
+               (list port max-waiting initial-connection-timeout default-host-table virtual-host-table))))
-     [x (error 'parse-configuration-table "malformed configuration ~s" x)]))
   
   ; parse-host : tst -> host-table
-  (define parse-host
+  (define (parse-host t)
-    (match-lambda
+    (define host-table (get-binding* 'host-table t `()))
-     [`(host-table
+    (define default-indices (get-binding* 'default-indices host-table `("index.html" "index.htm")))
-        (default-indices . ,default-indices)
+    (define log-format (get-binding 'log-format host-table 'parenthesized-default))
-        (log-format ,log-format)
+    (define messages (get-binding* 'messages host-table `()))
-        (messages
+    (define servlet-message (get-binding 'servlet-message messages "servlet-error.html"))
-         (servlet-message ,servlet-message)
+    (define authentication-message (get-binding 'authentication-message messages "forbidden.html"))
-         (authentication-message ,authentication-message)
+    (define servlets-refreshed (get-binding 'servlets-refreshed messages "servlet-refresh.html"))
-         (servlets-refreshed ,servlets-refreshed)
+    (define passwords-refreshed (get-binding 'passwords-refreshed messages "passwords-refresh.html"))
-         (passwords-refreshed ,passwords-refreshed)
+    (define file-not-found-message (get-binding 'file-not-found-message messages "not-found.html"))
-         (file-not-found-message ,file-not-found-message)
+    (define protocol-message (get-binding 'protocol-message messages "protocol-error.html"))
-         (protocol-message ,protocol-message)
+    (define collect-garbage (get-binding 'collect-garbage messages "collect-garbage.html"))
-         (collect-garbage ,collect-garbage))
+    (define timeouts (get-binding* 'timeouts host-table `()))
-        (timeouts
+    (define default-servlet-timeout (get-binding 'default-servlet-timeout timeouts 30))
-         (default-servlet-timeout ,default-servlet-timeout)
+    (define password-connection-timeout (get-binding 'password-connection-timeout timeouts 300))
-         (password-connection-timeout ,password-connection-timeout)
+    (define servlet-connection-timeout (get-binding 'servlet-connection-timeout timeouts (* 60 60 24)))
-         (servlet-connection-timeout ,servlet-connection-timeout)
+    (define file-per-byte-connection-timeout (get-binding 'file-per-byte-connection-timeout timeouts 1/20))
-         (file-per-byte-connection-timeout ,file-per-byte-connection-timeout)
+    (define file-base-connection-timeout (get-binding 'file-base-connection-timeout timeouts 30))
-         (file-base-connection-timeout ,file-base-connection-timeout))
+    (define paths (get-binding* 'paths host-table `()))
-        (paths
+    (define configuration-root (get-binding 'configuration-root paths "conf"))
-         (configuration-root ,configuration-root)
+    (define host-root (get-binding 'host-root paths "default-web-root"))
-         (host-root ,host-root)
+    (define log-file-path (get-binding 'log-file-path paths "log"))
-         (log-file-path ,log-file-path)
+    (define file-root (get-binding 'file-root paths "htdocs"))
-         (file-root ,file-root)
+    (define servlet-root (get-binding 'servlet-root paths "."))
-         (servlet-root ,servlet-root)
+    (define mime-types (get-binding 'mime-types paths "mime.types"))
-         (mime-types ,mime-types)
+    (define password-authentication (get-binding 'password-authentication paths "passwords"))
-         (password-authentication ,password-authentication)))
     (make-host-table
      default-indices log-format
      (make-messages servlet-message
@@ -75,8 +79,7 @@
                  file-root
                  servlet-root
                  mime-types
-                   password-authentication))]
+                 password-authentication)))
-     [x (error 'parse-host "malformed host ~s" x)]))
   
   ; nat? : tst -> bool
   (define (nat? x)

collects/web-server/servlet-helpers.ss

@@ -7,11 +7,10 @@
            (lib "url.ss" "net"))
   (require "util.ss"
            "response.ss"
-           "request-structs.ss")
+           "request-structs.ss"
+           "bindings.ss")
   (provide get-host
-           extract-binding/single
+           (all-from "bindings.ss")
-           extract-bindings
-           exists-binding?
            extract-user-pass
            build-suspender
            make-html-response/incremental
@@ -53,26 +52,6 @@
              (string->symbol (bytes->string/utf-8 v))])]
       [else DEFAULT-HOST-NAME]))
       
-  ; extract-binding/single : sym (listof (cons str str)) -> str
-  (define (extract-binding/single name bindings)
-    (let ([lst (extract-bindings name bindings)])
-      (cond
-        [(null? lst)
-         (error 'extract-binding/single "~e not found in ~e" name bindings)]
-        [(null? (cdr lst)) (car lst)]
-        [else (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)])))
-  
-  ; extract-bindings : sym (listof (cons str str)) -> (listof str)
-  (define (extract-bindings name bindings)
-    (map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
-  
-  ; exists-binding? : sym (listof (cons sym str)) -> bool
-  ; for checkboxes
-  (define (exists-binding? name bindings)
-    (if (assq name bindings)
-        #t
-        #f))
-  
   ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
   (define build-suspender
     (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])

collects/web-server/timer.ss

@@ -41,30 +41,34 @@
   ;;  the timer-manager thread
   ;; add-timer : number (-> void) -> timer
   (define (add-timer msecs thunk)
-    (let* ([now (current-inexact-milliseconds)]
+    (define now (current-inexact-milliseconds))
-           [timer
+    (define timer
       (make-timer (alarm-evt (+ now msecs))
                   (+ now msecs)
-                        thunk)])
+                  thunk))
-      (async-channel-put timer-ch 
+    (async-channel-put 
+     timer-ch 
      (lambda (timers)
-                     (cons timer timers)))
+       (list* timer timers)))
-      timer))
+    timer)
   
   ; revise-timer! : timer msecs (-> void) -> timer
   ; revise the timer to ring msecs from now
   (define (revise-timer! timer msecs thunk)
-    (let ([now (current-inexact-milliseconds)])
+    (define now (current-inexact-milliseconds))
     (async-channel-put 
      timer-ch 
      (lambda (timers)
        (set-timer-evt! timer (alarm-evt (+ now msecs)))
        (set-timer-expire-seconds! timer (+ now msecs))
        (set-timer-action! timer thunk)
-         timers))))
+       timers)))
   
   (define (cancel-timer! timer)
-    (revise-timer! timer 0 void))  
+    (async-channel-put
+     timer-ch
+     (lambda (timers)
+       (remq timer timers))))
   
   ; start-timer : num (-> void) -> timer
   ; to make a timer that calls to-do after sec from make-timer's application

collects/web-server/web-server-unit.ss

@@ -17,7 +17,9 @@
   (require (lib "tcp-sig.ss" "net")
            (lib "unitsig.ss")
            (lib "string.ss")
+           (lib "list.ss")
            (lib "url.ss" "net"))
+  
   (provide web-server@)  
   
   ;; ****************************************  
@@ -123,41 +125,42 @@
       (define initial-connection-timeout config:initial-connection-timeout)
       
       ;; dispatch : connection request -> void
+      (define dispatch-cache (make-cache-table))
       (define dispatch 
-        (let ([cache (make-cache-table)])
+        (host:make
-          (host:gen-dispatcher
          (lambda (host)
            (cache-table-lookup!
-              cache host
+            dispatch-cache host
             (lambda ()
+              (parameterize ([current-custodian (current-server-custodian)])
                 (host-info->dispatcher
                  (config:virtual-hosts (symbol->string host)))))))))
       
       ;; host-info->dispatcher : host-info -> conn request -> void
       (define (host-info->dispatcher host-info)
-        (sequencer:gen-dispatcher
+        (sequencer:make
-         (log:gen-dispatcher (host-log-format host-info)
+         (log:make #:log-format (host-log-format host-info)
-                             (host-log-path host-info))
+                   #:log-path (host-log-path host-info))
-         (passwords:gen-dispatcher (host-passwords host-info)
+         (passwords:make #:password-file (host-passwords host-info)
-                                   (timeouts-password (host-timeouts host-info))
+                         #:password-connection-timeout (timeouts-password (host-timeouts host-info))
-                                   (responders-authentication (host-responders host-info))
+                         #:authentication-responder (responders-authentication (host-responders host-info))
-                                   (responders-passwords-refreshed (host-responders host-info)))
+                         #:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
-         (path-procedure:gen-dispatcher "/conf/collect-garbage"
+         (path-procedure:make "/conf/collect-garbage"
                               (lambda ()
                                 (collect-garbage)
                                 ((responders-collect-garbage (host-responders host-info)))))
-         (servlets:gen-dispatcher config:instances config:scripts config:make-servlet-namespace
+         (servlets:make config:instances config:scripts config:make-servlet-namespace
-                                  (paths-servlet (host-paths host-info))
+                        #:servlet-root (paths-servlet (host-paths host-info))
-                                  (responders-servlets-refreshed (host-responders host-info))
+                        #:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info))
-                                  (responders-servlet-loading (host-responders host-info))
+                        #:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
-                                  (responders-servlet (host-responders host-info))
+                        #:responders-servlet (responders-servlet (host-responders host-info))
-                                  (responders-file-not-found (host-responders host-info))
+                        #:responders-file-not-found (responders-file-not-found (host-responders host-info))
-                                  (timeouts-servlet-connection (host-timeouts host-info))
+                        #:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
-                                  (timeouts-default-servlet (host-timeouts host-info)))
+                        #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
-         (files:gen-dispatcher (paths-htdocs (host-paths host-info))
+         (files:make #:htdocs-path (paths-htdocs (host-paths host-info))
-                               (paths-mime-types (host-paths host-info))
+                     #:mime-types-path (paths-mime-types (host-paths host-info))
-                               (host-indices host-info)
+                     #:indices (host-indices host-info)
-                               (responders-file-not-found (host-responders host-info)))))))
+                     #:file-not-found-responder (responders-file-not-found (host-responders host-info)))))))
   
   (define web-server@
     (compound-unit/sig