diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 199f98dc13..c819e7bc7c 100644 --- a/collects/handin-server/web-status-server.ss +++ b/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 diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss index a3a7102f10..1e81cdff5c 100644 --- a/collects/help/private/config.ss +++ b/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) diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 8dea44184f..ba4581dc7f 100644 --- a/collects/web-server/configuration.ss +++ b/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?)])) \ No newline at end of file + [default-configuration-table-path path?])) \ No newline at end of file diff --git a/collects/web-server/private/configuration-structures.ss b/collects/web-server/private/configuration-structures.ss deleted file mode 100644 index ef6bef1711..0000000000 --- a/collects/web-server/private/configuration-structures.ss +++ /dev/null @@ -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?)])])) \ No newline at end of file diff --git a/collects/web-server/private/configuration-table-structs.ss b/collects/web-server/private/configuration-table-structs.ss index 6a1b28ff67..4047994066 100644 --- a/collects/web-server/private/configuration-table-structs.ss +++ b/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?)])])) \ No newline at end of file diff --git a/collects/web-server/private/configuration-util.ss b/collects/web-server/private/configuration-util.ss index 6d0fe996b2..f054d1faa9 100644 --- a/collects/web-server/private/configuration-util.ss +++ b/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") diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/private/configuration.ss index 1171bc6ad4..6cfef722e4 100644 --- a/collects/web-server/private/configuration.ss +++ b/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?)])) \ No newline at end of file + (provide complete-configuration)) \ No newline at end of file diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss index 4a13056301..188694e4d2 100644 --- a/collects/web-server/private/configure.ss +++ b/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)) diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index e9f6c9420e..dd94ed741f 100644 --- a/collects/web-server/private/launch.ss +++ b/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@ diff --git a/collects/web-server/private/parse-table.ss b/collects/web-server/private/parse-table.ss index 0aacb2ef4c..24c7e25b2d 100644 --- a/collects/web-server/private/parse-table.ss +++ b/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 diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index e516c76097..993626f9db 100644 --- a/collects/web-server/private/util.ss +++ b/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") diff --git a/collects/web-server/tools/servlet-env.ss b/collects/web-server/tools/servlet-env.ss index 92af5dbfe0..a58c36a269 100644 --- a/collects/web-server/tools/servlet-env.ss +++ b/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) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index c341f637cb..e64e508503 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-structures.ss" + "private/configuration-table-structs.ss" "private/cache-table.ss" (rename "private/request.ss" the-read-request read-request)) diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 06e4ad70b1..80c58a2c04 100644 --- a/collects/web-server/web-server.ss +++ b/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)))