Stream-lining web-server configuration sub-system

svn: r6417

collects/handin-server/web-status-server.ss

@@ -9,6 +9,7 @@
            (lib "web-server-sig.ss" "web-server")
            (lib "web-config-sig.ss" "web-server")
            (lib "configuration.ss" "web-server")
+           (lib "namespace.ss" "web-server" "configuration")
            "private/config.ss")
 
   (provide serve-status)
@@ -58,7 +59,8 @@
 
     (define configuration
       (load-configuration-sexpr
-       web-dir config
+       config
+       #:web-server-root web-dir
        #:make-servlet-namespace
        (make-make-servlet-namespace
         #:to-be-copied-module-specs

collects/help/private/config.ss

@@ -42,7 +42,7 @@
                  (servlet-root ,servlet-root)
                  (mime-types "../../web-server/default-web-root/mime.types")
                  (password-authentication "passwords"))))])
-      (build-developer-configuration
+      (load-configuration-sexpr
        `((port ,internal-port)
          (max-waiting 40)
          (initial-connection-timeout 30)

collects/web-server/configuration.ss

@@ -1,14 +1,12 @@
 (module configuration mzscheme
-  (require (lib "unit.ss")
-           (lib "kw.ss")
+  (require (lib "kw.ss")
            (lib "contract.ss"))
   (require "private/configuration.ss"
-           "private/configuration-structures.ss"
            "private/configuration-table-structs.ss"
            "private/util.ss"
            "private/parse-table.ss"
            "web-config-sig.ss")
-  
+    
   (define default-configuration-table-path
     (build-path (collection-path "web-server") "configuration-table"))
   
@@ -17,75 +15,25 @@
     (parse-configuration-table (call-with-input-file table-file-name read)))
   
   ; load-configuration : path -> configuration
-  (define (load-configuration table-file-name)
-    (complete-configuration (directory-part table-file-name) (get-configuration table-file-name)))
-  
-  ; load-configuration-sexpr : string? sexp -> configuration
-  (define/kw (load-configuration-sexpr web-server-root sexpr
-                                       #:other-keys bct-keys)                                       
-    (define table 
-      (parse-configuration-table sexpr))
-    (define default-host
-      (apply-default-functions-to-host-table 
-       web-server-root 
-       (configuration-table-default-host table)))
-    (apply build-configuration table
-           (lambda (host) default-host)
+  (define/kw (load-configuration table-file-name
+                                 #:other-keys bct-keys)
+    (apply load-configuration-sexpr 
+           (call-with-input-file table-file-name read)
+           #:web-server-root (directory-part table-file-name)
            bct-keys))
   
-  ; load-developer-configuration : path -> configuration
-  (define (load-developer-configuration table-file-name)
-    (complete-developer-configuration
-     (directory-part table-file-name)
-     (get-configuration table-file-name)))
-  
-  ; build-developer-configuration : tst -> configuration-table
-  (define (build-developer-configuration s-expr)
-    (complete-configuration ; used to be: complete-developer-configuration
-     (directory-part default-configuration-table-path)
-     (parse-configuration-table s-expr)))
-  
-  
-  ; : (listof (cons sym TST)) -> configuration
-  ; more here - this is ugly.  It also does not catch "unbound identifiers" since I use symbols.
-  ; I considered several other solutions:
-  ; - write the compound unit multiple times (no abstraction)
-  ; - use opt-lambda and pass in 'please-use-the-default for unchanged flags
-  ; - write three different functional updaters and re-compound the unit 1--3 times
-  (define (update-configuration configuration flags)    
-    (define-unit new-local-config@
-      (import (prefix raw: web-config^))
-      (export web-config^)
-      (init-depend web-config^)
-      
-      (define max-waiting raw:max-waiting)
-      (define virtual-hosts raw:virtual-hosts)
-      (define access raw:access)
-      (define scripts raw:scripts)
-      (define initial-connection-timeout raw:initial-connection-timeout)
-      
-      (define port (extract-flag 'port flags raw:port))
-      (define listen-ip (extract-flag 'ip-address flags raw:listen-ip))
-      (define instances (extract-flag 'instances flags raw:instances))
-      (define make-servlet-namespace (extract-flag 'namespace flags raw:make-servlet-namespace)))
+  ; load-configuration-sexpr : string? sexp -> configuration
+  (define/kw (load-configuration-sexpr sexpr
+                                       #:key
+                                       [web-server-root (directory-part default-configuration-table-path)]
+                                       #:other-keys bct-keys)
+    (apply complete-configuration
+           web-server-root
+           (parse-configuration-table sexpr)
+           bct-keys))
     
-    (define-unit/new-import-export config@ (import) (export web-config^)
-      ((web-config^) configuration))
-    
-    (define-compound-unit/infer new-config@
-      (import)
-      (export NL)
-      (link (((L : web-config^)) config@)
-            (((NL : web-config^)) new-local-config@ L)))
-    
-    new-config@)
-  
-  (provide load-configuration-sexpr)
+  (provide load-configuration
+           load-configuration-sexpr)
   (provide/contract
-   [complete-configuration (path-string? configuration-table? . -> . configuration?)]
    [get-configuration (path-string? . -> . configuration-table?)]
-   [build-developer-configuration (list? . -> . configuration?)]
-   [default-configuration-table-path path?]
-   [update-configuration (configuration? (listof (cons/c symbol? any/c)) . -> . configuration?)]
-   [load-configuration (path-string? . -> . configuration?)]
-   [load-developer-configuration (path-string? . -> . configuration?)]))
+   [default-configuration-table-path path?]))

collects/web-server/private/configuration-structures.ss

@@ -1,51 +0,0 @@
-(module configuration-structures mzscheme
-  (require (only (lib "unit.ss") unit?)
-           (lib "contract.ss")
-           (lib "url.ss" "net"))
-  (require "configuration-table-structs.ss"
-           "../response-structs.ss")           
-  
-  ; configuration is now a unit.  See sig.ss
-  (define configuration?
-    unit?)
-  
-  ; host = (make-host (listof str) sym string
-  ;                   passwords responders timeouts paths)
-  (define-struct host (indices log-format log-path passwords responders timeouts paths))  
-  
-  ; passwords = (listof (list* relm:str protected-dir-regexp:str
-  ;                            (listof (list user:sym password:str))))
-  
-  ; responders = (make-responders (url tst -> response)
-  ;                               (url tst -> response)
-  ;                               (url (cons sym str) -> response)
-  ;                               response
-  ;                               response
-  ;                               (url -> response)
-  ;                               response
-  ;                               response)
-  (define-struct responders
-    (servlet servlet-loading authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
-
-  (provide ; all-from
-   (struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
-   (struct paths (host-base log htdocs mime-types servlet)))
-  (provide/contract
-   [configuration? (any/c . -> . boolean?)]
-   [struct host 
-           ([indices (listof string?)]
-            [log-format symbol?]
-            [log-path (or/c false/c path-string?)]
-            [passwords (or/c false/c path-string?)]
-            [responders responders?]
-            [timeouts timeouts?]
-            [paths paths?])]
-   [struct responders
-           ([servlet (url? any/c . -> . response?)]
-            [servlet-loading (url? any/c . -> . response?)]
-            [authentication (url? (cons/c symbol? string?) . -> . response?)]
-            [servlets-refreshed (-> response?)]
-            [passwords-refreshed (-> response?)]
-            [file-not-found (url? . -> . response?)]
-            [protocol (url? . -> . response?)]
-            [collect-garbage (-> response?)])]))

collects/web-server/private/configuration-table-structs.ss

@@ -1,5 +1,7 @@
 (module configuration-table-structs mzscheme
-  (require (lib "contract.ss"))
+  (require (lib "contract.ss")
+           (lib "url.ss" "net"))
+  (require "../response-structs.ss")           
   
   ; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table)))
   (define-struct configuration-table
@@ -8,10 +10,15 @@
   ; host-table = (make-host-table (listof str) sym messages timeouts paths)
   (define-struct host-table (indices log-format messages timeouts paths))
   
+  (define-struct host (indices log-format log-path passwords responders timeouts paths))  
+  
+  (define-struct responders
+    (servlet servlet-loading authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
+  
   ; messages = (make-messages str^6)
   (define-struct messages
     (servlet authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
-
+  
   ; timeouts = (make-timeouts nat^5)
   (define-struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
   
@@ -31,6 +38,23 @@
             [messages messages?]
             [timeouts timeouts?]
             [paths paths?])]
+   [struct host 
+           ([indices (listof string?)]
+            [log-format symbol?]
+            [log-path (or/c false/c path-string?)]
+            [passwords (or/c false/c path-string?)]
+            [responders responders?]
+            [timeouts timeouts?]
+            [paths paths?])]
+   [struct responders
+           ([servlet (url? any/c . -> . response?)]
+            [servlet-loading (url? any/c . -> . response?)]
+            [authentication (url? (cons/c symbol? string?) . -> . response?)]
+            [servlets-refreshed (-> response?)]
+            [passwords-refreshed (-> response?)]
+            [file-not-found (url? . -> . response?)]
+            [protocol (url? . -> . response?)]
+            [collect-garbage (-> response?)])]
    [struct messages
            ([servlet string?]
             [authentication string?]
@@ -52,4 +76,4 @@
             [htdocs (or/c false/c path-string?)]
             [servlet (or/c false/c path-string?)]
             [mime-types (or/c false/c path-string?)]
-            [passwords (or/c false/c path-string?)])]))
+            [passwords (or/c false/c path-string?)])]))

collects/web-server/private/configuration-util.ss

@@ -1,6 +1,5 @@
 (module configuration-util mzscheme
   (require (lib "contract.ss")
-           (lib "file.ss")           
            (lib "pretty.ss"))
   (require "configuration-table-structs.ss")   
   

collects/web-server/private/configuration.ss

@@ -1,9 +1,7 @@
 (module configuration mzscheme
   (require (lib "unit.ss")
-           (lib "kw.ss")
-           (lib "contract.ss"))
-  (require "configuration-structures.ss"
-           "configuration-table-structs.ss"
+           (lib "kw.ss"))
+  (require "configuration-table-structs.ss"
            "util.ss"
            "cache-table.ss"
            "../configuration/namespace.ss"
@@ -11,46 +9,44 @@
            "../web-config-sig.ss")
   
   ; : str configuration-table -> configuration
-  (define (complete-configuration base table)
-    (build-configuration
-     table
-     (let ([default-host
-             (apply-default-functions-to-host-table
-              base (configuration-table-default-host table))]
-           [expanded-virtual-host-table
-            (map (lambda (x)
-                   (list (regexp (string-append (car x) "(:[0-9]*)?"))
-                         (apply-default-functions-to-host-table base (cdr x))))
-                 (configuration-table-virtual-hosts table))])
-       (gen-virtual-hosts expanded-virtual-host-table default-host))))
-  
-  ; complete-developer-configuration : str configuration-table -> configuration
-  (define (complete-developer-configuration base table)
-    (build-configuration
-     table
-     (gen-virtual-hosts null (apply-default-functions-to-host-table
-                              base
-                              (configuration-table-default-host table)))))
+  (define/kw (complete-configuration base table
+                                     #:other-keys bct-keys)
+    (define default-host
+      (apply-default-functions-to-host-table
+       base (configuration-table-default-host table)))
+    (define expanded-virtual-host-table
+      (map (lambda (x)
+             (list (regexp (string-append (car x) "(:[0-9]*)?"))
+                   (apply-default-functions-to-host-table base (cdr x))))
+           (configuration-table-virtual-hosts table)))
+    (apply build-configuration
+           table
+           (gen-virtual-hosts expanded-virtual-host-table default-host)
+           bct-keys))
   
+  (define default-make-servlet-namespace (make-make-servlet-namespace))
+
   ; : configuration-table host-table -> configuration
   (define/kw (build-configuration table the-virtual-hosts
                                   #:key
+                                  [port #f]
+                                  [listen-ip #f]
                                   [make-servlet-namespace default-make-servlet-namespace])
+    (define the-port (or port (configuration-table-port table)))
+    (define the-listen-ip (or listen-ip #f))
     (define the-make-servlet-namespace make-servlet-namespace)
     (unit
       (import)
       (export web-config^)
-      (define port (configuration-table-port table))
+      (define port the-port)
       (define max-waiting (configuration-table-max-waiting table))
-      (define listen-ip #f) ; more here - add to configuration table
+      (define listen-ip the-listen-ip)
       (define initial-connection-timeout (configuration-table-initial-connection-timeout table))
       (define virtual-hosts the-virtual-hosts)
       (define access (make-hash-table))
       (define instances (make-hash-table))
       (define scripts (box (make-cache-table)))
       (define make-servlet-namespace the-make-servlet-namespace)))
-  
-  (define default-make-servlet-namespace (make-make-servlet-namespace))
     
   ; apply-default-functions-to-host-table : str host-table -> host
   ;; Greg P: web-server-root is the directory-part of the path to the configuration-table (I don't think I like this.)
@@ -100,9 +96,4 @@
                  expanded-virtual-host-table)
           default-host)))
   
-  (provide 
-   build-configuration
-   apply-default-functions-to-host-table)
-  (provide/contract
-   [complete-configuration (path-string? configuration-table? . -> . configuration?)]
-   [complete-developer-configuration (path-string? configuration-table? . -> . configuration?)]))
+  (provide complete-configuration))

collects/web-server/private/configure.ss

@@ -163,7 +163,7 @@
         (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)
+                  (delete-hosts (update-table configuration update-bindings)
                                 (foldr (lambda (b acc)
                                          (if (string=? "Delete" (cdr b))
                                              (cons (symbol->string (car b)) acc)
@@ -365,8 +365,8 @@
   (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)
+  ; update-table : configuration-table bindings -> configuration-table
+  (define (update-table 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))

collects/web-server/private/launch.ss

@@ -43,10 +43,10 @@
                   (error 'web-server "ip-address expects a numeric ip-address (i.e. 127.0.0.1); given ~s" ip-address))))
          ("Restrict access to come from ip-address" "ip-address")]))
      (lambda (flags)
-       (update-configuration
-        (load-configuration
-         (extract-flag 'config flags default-configuration-table-path))
-        flags))
+       (load-configuration
+        (extract-flag 'config flags default-configuration-table-path)
+        #:port (extract-flag 'port flags #f)
+        #:listen-ip (extract-flag 'ip-address flags #f)))
      '()))
 
   (define-compound-unit launch@

collects/web-server/private/parse-table.ss

@@ -19,7 +19,7 @@
     (define default-host-table (get-binding* 'default-host-table t `()))
     (define virtual-host-table (get-binding* 'virtual-host-table t `()))
     (if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
-             ; more here - list? isn't really picky enough
+             ; XXX - list? isn't really picky enough
              (list? virtual-host-table))
         (make-configuration-table
          port max-waiting initial-connection-timeout

collects/web-server/private/util.ss

@@ -1,9 +1,7 @@
 (module util mzscheme
   (require (lib "contract.ss")
            (lib "string.ss")
-           (lib "list.ss")
            (lib "url.ss" "net")
-           (lib "plt-match.ss")
            (lib "uri-codec.ss" "net"))
   (require "../request-structs.ss")
   

collects/web-server/tools/servlet-env.ss

@@ -54,7 +54,7 @@
       final-value))
   
   (define (build-standalone-servlet-configuration the-port the-path the-servlet)
-    (let ([basic-configuration@ (load-developer-configuration default-configuration-table-path)]
+    (let ([basic-configuration@ (load-configuration default-configuration-table-path)]
           [the-scripts (make-cache-table)])
       (define-values/invoke-unit basic-configuration@ 
         (import) 

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

@@ -6,7 +6,7 @@
            "private/dispatch-server-unit.ss"
            "private/dispatch-server-sig.ss"
            "private/web-server-structs.ss"
-           "private/configuration-structures.ss"
+           "private/configuration-table-structs.ss"
            "private/cache-table.ss"
            (rename "private/request.ss" 
                    the-read-request read-request))

collects/web-server/web-server.ss

@@ -11,15 +11,14 @@
            "web-server-sig.ss"
            "web-server-unit.ss"
 	   "configuration.ss"
-           (prefix http: "private/request.ss")
-           "private/configuration-structures.ss")
+           (prefix http: "private/request.ss"))
   (provide
    serve
    serve/ports
    serve/ips+ports)
   (provide/contract
    [do-not-return (-> void)]
-   [serve/web-config@ (configuration? . -> . (-> void?))])
+   [serve/web-config@ (unit? . -> . (-> void?))])
   
   (define (do-not-return)
     (semaphore-wait (make-semaphore 0)))