From c9e36c309144dcbb327b8498853e827b3fc7625b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 30 May 2007 22:15:36 +0000 Subject: [PATCH] Renaming configuration-table modules svn: r6419 --- .../configuration-table-structs.ss | 0 .../configuration-table.ss} | 79 ++++++++++++++----- .../web-server/private/configuration-util.ss | 62 --------------- collects/web-server/private/configure.ss | 11 ++- collects/web-server/private/setup-launch.ss | 6 +- collects/web-server/web-config-unit.ss | 6 +- collects/web-server/web-server-unit.ss | 2 +- 7 files changed, 73 insertions(+), 93 deletions(-) rename collects/web-server/{private => configuration}/configuration-table-structs.ss (100%) rename collects/web-server/{private/parse-table.ss => configuration/configuration-table.ss} (59%) delete mode 100644 collects/web-server/private/configuration-util.ss diff --git a/collects/web-server/private/configuration-table-structs.ss b/collects/web-server/configuration/configuration-table-structs.ss similarity index 100% rename from collects/web-server/private/configuration-table-structs.ss rename to collects/web-server/configuration/configuration-table-structs.ss diff --git a/collects/web-server/private/parse-table.ss b/collects/web-server/configuration/configuration-table.ss similarity index 59% rename from collects/web-server/private/parse-table.ss rename to collects/web-server/configuration/configuration-table.ss index 24c7e25b2d..dafd726745 100644 --- a/collects/web-server/private/parse-table.ss +++ b/collects/web-server/configuration/configuration-table.ss @@ -1,8 +1,12 @@ -(module parse-table mzscheme - (require (lib "list.ss") - (lib "contract.ss")) +(module configuration-table mzscheme + (require (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) - ; XXX - list? isn't really picky enough - (list? virtual-host-table)) - (make-configuration-table - port max-waiting initial-connection-timeout - (parse-host default-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)))) + (make-configuration-table + port max-waiting initial-connection-timeout + (parse-host default-host-table) + (map (lambda (h) + (cons (car h) (parse-host (cdr h)))) + virtual-host-table))) ; parse-host : tst -> host-table (define (parse-host t) @@ -81,9 +78,49 @@ mime-types password-authentication))) - ; nat? : tst -> bool - (define (nat? x) - (and (number? x) (exact? x) (integer? x) (<= 0 x))) + ; write-configuration-table : configuration-table path -> void + ; writes out the new configuration file + (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 - [parse-configuration-table (list? . -> . configuration-table?)])) \ No newline at end of file + ; host-table->sexpr : host-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))))))) \ No newline at end of file diff --git a/collects/web-server/private/configuration-util.ss b/collects/web-server/private/configuration-util.ss deleted file mode 100644 index f054d1faa9..0000000000 --- a/collects/web-server/private/configuration-util.ss +++ /dev/null @@ -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)])) \ No newline at end of file diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss index 70af0ae794..a4768f8b5e 100644 --- a/collects/web-server/private/configure.ss +++ b/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 "parse-table.ss" "web-server" "private") - (lib "configuration-util.ss" "web-server" "private") + (lib "configuration-table-structs.ss" "web-server" "configuration") + (lib "configuration-table.ss" "web-server" "configuration") (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) diff --git a/collects/web-server/private/setup-launch.ss b/collects/web-server/private/setup-launch.ss index fa49f2dfab..e4f3a25d77 100644 --- a/collects/web-server/private/setup-launch.ss +++ b/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" - "util.ss" - "configuration-util.ss") + "../configuration/configuration-table-structs.ss" + "../configuration/configuration-table.ss" + "util.ss") (parse-command-line "web-server-setup" diff --git a/collects/web-server/web-config-unit.ss b/collects/web-server/web-config-unit.ss index 7cae0de128..59f5fbf7ad 100644 --- a/collects/web-server/web-config-unit.ss +++ b/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" - "private/util.ss" + (require "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") diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index e64e508503..2a069ab5a0 100644 --- a/collects/web-server/web-server-unit.ss +++ b/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))