diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index c819e7bc7c..cd35861bdf 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -8,7 +8,7 @@ (lib "web-server-unit.ss" "web-server") (lib "web-server-sig.ss" "web-server") (lib "web-config-sig.ss" "web-server") - (lib "configuration.ss" "web-server") + (lib "web-config-unit.ss" "web-server") (lib "namespace.ss" "web-server" "configuration") "private/config.ss") @@ -58,7 +58,7 @@ (virtual-host-table))) (define configuration - (load-configuration-sexpr + (configuration-table-sexpr->web-config@ config #:web-server-root web-dir #:make-servlet-namespace diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss index 1e81cdff5c..c2bcd95a6a 100644 --- a/collects/help/private/config.ss +++ b/collects/help/private/config.ss @@ -1,6 +1,6 @@ (module config mzscheme (require (lib "file.ss") - (lib "configuration.ss" "web-server") + (lib "web-config-unit.ss" "web-server") (lib "dirs.ss" "setup") (lib "config.ss" "planet") "internal-hp.ss") @@ -42,7 +42,7 @@ (servlet-root ,servlet-root) (mime-types "../../web-server/default-web-root/mime.types") (password-authentication "passwords"))))]) - (load-configuration-sexpr + (configuration-table-sexpr->web-config@ `((port ,internal-port) (max-waiting 40) (initial-connection-timeout 30) diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss deleted file mode 100644 index ba4581dc7f..0000000000 --- a/collects/web-server/configuration.ss +++ /dev/null @@ -1,39 +0,0 @@ -(module configuration mzscheme - (require (lib "kw.ss") - (lib "contract.ss")) - (require "private/configuration.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")) - - ; get-configuration : path -> configuration-table - (define (get-configuration table-file-name) - (parse-configuration-table (call-with-input-file table-file-name read))) - - ; load-configuration : path -> configuration - (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-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)) - - (provide load-configuration - load-configuration-sexpr) - (provide/contract - [get-configuration (path-string? . -> . configuration-table?)] - [default-configuration-table-path path?])) \ No newline at end of file diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss index 188694e4d2..70af0ae794 100644 --- a/collects/web-server/private/configure.ss +++ b/collects/web-server/private/configure.ss @@ -5,7 +5,7 @@ (lib "list.ss") (lib "pretty.ss") (lib "file.ss") - (only (lib "configuration.ss" "web-server") + (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") diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index dd94ed741f..4fe3077704 100644 --- a/collects/web-server/private/launch.ss +++ b/collects/web-server/private/launch.ss @@ -4,11 +4,11 @@ (lib "unit.ss") (lib "tcp-sig.ss" "net")) (require "util.ss" + "../web-config-unit.ss" "../web-config-sig.ss" "../web-server-unit.ss" - "../web-server-sig.ss" - "../configuration.ss") - + "../web-server-sig.ss") + (define configuration@ (parse-command-line "web-server" @@ -17,11 +17,11 @@ [("-f" "--configuration-table") ,(lambda (flag file-name) (cond - [(not (file-exists? file-name)) - (error 'web-server "configuration file ~s not found" file-name)] - [(not (memq 'read (file-or-directory-permissions file-name))) - (error 'web-server "configuration file ~s is not readable" file-name)] - [else (cons 'config (string->path file-name))])) + [(not (file-exists? file-name)) + (error 'web-server "configuration file ~s not found" file-name)] + [(not (memq 'read (file-or-directory-permissions file-name))) + (error 'web-server "configuration file ~s is not readable" file-name)] + [else (cons 'config (string->path file-name))])) ("Use an alternate configuration table" "file-name")] [("-p" "--port") ,(lambda (flag port) @@ -43,12 +43,12 @@ (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) - (load-configuration + (configuration-table->web-config@ (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@ (import (T : tcp^)) (export S) @@ -60,5 +60,5 @@ launch@ (import tcp^) (export web-server^)) - + (provide serve)) \ No newline at end of file diff --git a/collects/web-server/private/setup-launch.ss b/collects/web-server/private/setup-launch.ss index 7618cebd06..fa49f2dfab 100644 --- a/collects/web-server/private/setup-launch.ss +++ b/collects/web-server/private/setup-launch.ss @@ -2,7 +2,7 @@ (require (lib "cmdline.ss") (lib "file.ss") (lib "struct.ss")) - (require "../configuration.ss" + (require "../web-config-unit.ss" "configuration-table-structs.ss" "util.ss" "configuration-util.ss") @@ -35,7 +35,7 @@ ;; Write configuration-table into dest/configuration-table (write-configuration-table (copy-struct configuration-table - (get-configuration default-configuration-table-path) + (read-configuration-table default-configuration-table-path) [configuration-table-port port]) (build-path dest "configuration-table")))) '())) \ No newline at end of file diff --git a/collects/web-server/tools/servlet-env.ss b/collects/web-server/tools/servlet-env.ss index a58c36a269..f5ba4e6cc0 100644 --- a/collects/web-server/tools/servlet-env.ss +++ b/collects/web-server/tools/servlet-env.ss @@ -1,8 +1,8 @@ (module servlet-env mzscheme (require (lib "sendurl.ss" "net") (lib "unit.ss")) - (require "../configuration.ss" - "../web-server.ss" + (require "../web-server.ss" + "../web-config-unit.ss" "../web-config-sig.ss" "../private/util.ss" "../response-structs.ss" @@ -54,7 +54,7 @@ final-value)) (define (build-standalone-servlet-configuration the-port the-path the-servlet) - (let ([basic-configuration@ (load-configuration default-configuration-table-path)] + (let ([basic-configuration@ (configuration-table->web-config@ default-configuration-table-path)] [the-scripts (make-cache-table)]) (define-values/invoke-unit basic-configuration@ (import) diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/web-config-unit.ss similarity index 71% rename from collects/web-server/private/configuration.ss rename to collects/web-server/web-config-unit.ss index 6cfef722e4..7cae0de128 100644 --- a/collects/web-server/private/configuration.ss +++ b/collects/web-server/web-config-unit.ss @@ -1,12 +1,44 @@ -(module configuration mzscheme +(module web-config-unit mzscheme (require (lib "unit.ss") - (lib "kw.ss")) - (require "configuration-table-structs.ss" - "util.ss" - "cache-table.ss" - "../configuration/namespace.ss" - "../configuration/responders.ss" - "../web-config-sig.ss") + (lib "kw.ss") + (lib "contract.ss")) + (require "private/configuration-table-structs.ss" + "private/util.ss" + "private/cache-table.ss" + "private/parse-table.ss" + "configuration/namespace.ss" + "configuration/responders.ss" + "web-config-sig.ss") + (provide configuration-table->web-config@ + configuration-table-sexpr->web-config@) + (provide/contract + [read-configuration-table (path-string? . -> . configuration-table?)] + [default-configuration-table-path path?]) + + (define default-configuration-table-path + (build-path (collection-path "web-server") "configuration-table")) + + ; read-configuration-table : path -> configuration-table + (define (read-configuration-table table-file-name) + (parse-configuration-table (call-with-input-file table-file-name read))) + + ; configuration-table->web-config@ : path -> configuration + (define/kw (configuration-table->web-config@ table-file-name + #:other-keys bct-keys) + (apply configuration-table-sexpr->web-config@ + (call-with-input-file table-file-name read) + #:web-server-root (directory-part table-file-name) + bct-keys)) + + ; configuration-table-sexpr->web-config@ : string? sexp -> configuration + (define/kw (configuration-table-sexpr->web-config@ 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)) ; : str configuration-table -> configuration (define/kw (complete-configuration base table @@ -25,7 +57,7 @@ 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 @@ -47,7 +79,7 @@ (define instances (make-hash-table)) (define scripts (box (make-cache-table))) (define make-servlet-namespace the-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.) (define (apply-default-functions-to-host-table web-server-root host-table) @@ -94,6 +126,4 @@ (and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number) (cadr x))) expanded-virtual-host-table) - default-host))) - - (provide complete-configuration)) \ No newline at end of file + default-host)))) \ No newline at end of file diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 80c58a2c04..70b45ff927 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -10,7 +10,6 @@ "web-config-sig.ss" "web-server-sig.ss" "web-server-unit.ss" - "configuration.ss" (prefix http: "private/request.ss")) (provide serve