Renaming configuration-table modules

svn: r6419

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

@@ -1,8 +1,12 @@
-(module parse-table mzscheme
+(module configuration-table mzscheme
-  (require (lib "list.ss")
+  (require (lib "contract.ss")
-           (lib "contract.ss"))
+           (lib "list.ss")
+           (lib "pretty.ss"))
   (require "configuration-table-structs.ss"
            "../servlet/bindings.ss")
+  (provide/contract
+   [write-configuration-table (configuration-table? path-string? . -> . void)]
+   [parse-configuration-table (list? . -> . configuration-table?)])
   
   (define (get-binding key bindings default)
     (first (get-binding* key bindings (list default))))
@@ -18,19 +22,12 @@
     (define initial-connection-timeout (get-binding 'initial-connection-timeout t 30))
     (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)
+    (make-configuration-table
-             ; XXX - list? isn't really picky enough
+     port max-waiting initial-connection-timeout
-             (list? virtual-host-table))
+     (parse-host default-host-table)
-        (make-configuration-table
+     (map (lambda (h)
-         port max-waiting initial-connection-timeout
+            (cons (car h) (parse-host (cdr h))))
-         (parse-host default-host-table)
+          virtual-host-table)))
-         (map (lambda (h)
-                (if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
-                    (cons (car h) (parse-host (cdr h)))
-                    (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))))
   
   ; parse-host : tst -> host-table
   (define (parse-host t)
@@ -81,9 +78,49 @@
                  mime-types
                  password-authentication)))
   
-  ; nat? : tst -> bool
+  ; write-configuration-table : configuration-table path -> void
-  (define (nat? x)
+  ; writes out the new configuration file
-    (and (number? x) (exact? x) (integer? x) (<= 0 x)))
+  (define (write-configuration-table new configuration-path)
+    (define sexpr
+      `((port ,(configuration-table-port new))
+       (max-waiting ,(configuration-table-max-waiting new))
+       (initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
+       (default-host-table
+         ,(host-table->sexpr (configuration-table-default-host new)))
+       (virtual-host-table
+        . ,(map (lambda (h) (list (car h) (host-table->sexpr (cdr h))))
+                (configuration-table-virtual-hosts new)))))
+    (call-with-output-file configuration-path
+      (lambda (out) (pretty-print sexpr out))
+      'truncate))
   
-  (provide/contract
+  ; host-table->sexpr : host-table
-   [parse-configuration-table (list? . -> . configuration-table?)]))
+  (define (host-table->sexpr host)
+    (let ([t (host-table-timeouts host)]
+          [p (host-table-paths host)]
+          [m (host-table-messages host)])
+      `(host-table
+        (default-indices "index.html" "index.htm")
+        (log-format parenthesized-default)
+        (messages
+         (servlet-message ,(messages-servlet m))
+         (authentication-message ,(messages-authentication m))
+         (servlets-refreshed ,(messages-servlets-refreshed m))
+         (passwords-refreshed ,(messages-passwords-refreshed m))
+         (file-not-found-message ,(messages-file-not-found m))
+         (protocol-message ,(messages-protocol m))
+         (collect-garbage ,(messages-collect-garbage m)))
+        (timeouts
+         (default-servlet-timeout ,(timeouts-default-servlet t))
+         (password-connection-timeout ,(timeouts-password t))
+         (servlet-connection-timeout ,(timeouts-servlet-connection t))
+         (file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
+         (file-base-connection-timeout ,(timeouts-file-base t)))
+        (paths
+         (configuration-root ,(paths-conf p))
+         (host-root ,(paths-host-base p))
+         (log-file-path ,(paths-log p))
+         (file-root ,(paths-htdocs p))
+         (servlet-root ,(paths-servlet p))
+         (mime-types ,(paths-mime-types p))
+         (password-authentication ,(paths-passwords p)))))))

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

@@ -1,62 +0,0 @@
-(module configuration-util mzscheme
-  (require (lib "contract.ss")
-           (lib "pretty.ss"))
-  (require "configuration-table-structs.ss")   
-  
-  ; write-configuration-table : configuration-table path -> void
-  ; writes out the new configuration file
-  (define (write-configuration-table new configuration-path)
-    (write-to-file
-     configuration-path
-     `((port ,(configuration-table-port new))
-       (max-waiting ,(configuration-table-max-waiting new))
-       (initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
-       (default-host-table
-         ,(format-host (configuration-table-default-host new)))
-       (virtual-host-table
-        . ,(map (lambda (h) (list (car h) (format-host (cdr h))))
-                (configuration-table-virtual-hosts new))))))
-  
-  ; format-host : host-table
-  (define (format-host host)
-    (let ([t (host-table-timeouts host)]
-          [p (host-table-paths host)]
-          [m (host-table-messages host)])
-      `(host-table
-        ; more here - configure
-        (default-indices "index.html" "index.htm")
-        ; more here - configure
-        (log-format parenthesized-default)
-        (messages
-         (servlet-message ,(messages-servlet m))
-         (authentication-message ,(messages-authentication m))
-         (servlets-refreshed ,(messages-servlets-refreshed m))
-         (passwords-refreshed ,(messages-passwords-refreshed m))
-         (file-not-found-message ,(messages-file-not-found m))
-         (protocol-message ,(messages-protocol m))
-         (collect-garbage ,(messages-collect-garbage m)))
-        (timeouts
-         (default-servlet-timeout ,(timeouts-default-servlet t))
-         (password-connection-timeout ,(timeouts-password t))
-         (servlet-connection-timeout ,(timeouts-servlet-connection t))
-         (file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
-         (file-base-connection-timeout ,(timeouts-file-base t)))
-        (paths
-         (configuration-root ,(paths-conf p))
-         (host-root ,(paths-host-base p))
-         (log-file-path ,(paths-log p))
-         (file-root ,(paths-htdocs p))
-         (servlet-root ,(paths-servlet p))
-         (mime-types ,(paths-mime-types p))
-         (password-authentication ,(paths-passwords p))))))
-  
-  ; write-to-file : str TST -> void
-  (define (write-to-file file-name x)
-    (call-with-output-file file-name
-      (lambda (out) (pretty-print x out))
-      'truncate))
-  
-  (provide/contract
-   [write-configuration-table (configuration-table? path-string? . -> . void)]
-   [format-host (host-table? . -> . list?)]
-   [write-to-file (path-string? list? . -> . void)]))

collects/web-server/private/configure.ss

@@ -7,9 +7,8 @@
            (lib "file.ss")
            (only (lib "web-config-unit.ss" "web-server")
                  default-configuration-table-path)
-           (lib "configuration-table-structs.ss" "web-server" "private")
+           (lib "configuration-table-structs.ss" "web-server" "configuration")
-           (lib "parse-table.ss" "web-server" "private")
+           (lib "configuration-table.ss" "web-server" "configuration")           
-           (lib "configuration-util.ss" "web-server" "private")
            (lib "util.ss" "web-server" "private"))
   (provide
    interface-version timeout
@@ -42,6 +41,12 @@
                (body ,body-attributes
                      (form ([action ,k-url] [method "post"])
                            ,@content))))))
+    
+  ; write-to-file : str TST -> void
+  (define (write-to-file file-name x)
+    (call-with-output-file file-name
+      (lambda (out) (pretty-print x out))
+      'truncate))
   
   (define default-configuration-path default-configuration-table-path)
   (define (set-config-path! new)

collects/web-server/private/setup-launch.ss

@@ -3,9 +3,9 @@
            (lib "file.ss")
            (lib "struct.ss"))
   (require "../web-config-unit.ss"
-           "configuration-table-structs.ss"
+           "../configuration/configuration-table-structs.ss"
-           "util.ss"
+           "../configuration/configuration-table.ss"
-           "configuration-util.ss")
+           "util.ss")
   
   (parse-command-line
    "web-server-setup"

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

@@ -2,10 +2,10 @@
   (require (lib "unit.ss")
            (lib "kw.ss")
            (lib "contract.ss"))
-  (require "private/configuration-table-structs.ss"
+  (require "private/util.ss"
-           "private/util.ss"
            "private/cache-table.ss"
-           "private/parse-table.ss"
+           "configuration/configuration-table-structs.ss"
+           "configuration/configuration-table.ss"
            "configuration/namespace.ss"
            "configuration/responders.ss"
            "web-config-sig.ss")

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-table-structs.ss"
+           "configuration/configuration-table-structs.ss"
            "private/cache-table.ss"
            (rename "private/request.ss" 
                    the-read-request read-request))