From eff8a409a9998a74369c1ace451ee88103466bba Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 14 Nov 2006 05:13:47 +0000 Subject: [PATCH] Eli svn: r4847 --- collects/help/private/config.ss | 2 +- collects/web-server/configuration.ss | 22 +++--- collects/web-server/private/configuration.ss | 83 +++++++++----------- collects/web-server/private/util.ss | 36 ++++----- 4 files changed, 68 insertions(+), 75 deletions(-) diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss index 52c3cbef3b..a3a7102f10 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/vhosts + (build-developer-configuration `((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 fd63db8bf0..3d4ee76cdc 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -1,5 +1,6 @@ (module configuration mzscheme (require (lib "unitsig.ss") + (lib "kw.ss") (lib "list.ss") (lib "contract.ss")) (require "private/configuration.ss" @@ -15,28 +16,29 @@ ; 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 (load-configuration table-file-name) (complete-configuration (directory-part table-file-name) (get-configuration table-file-name))) ; load-configuration-sexpr : sexp -> configuration - (define (load-configuration-sexpr sexpr) - (build-configuration (parse-configuration-table sexpr) empty)) + (define/kw (load-configuration-sexpr sexpr + #:other-keys bct-keys) + (define table (parse-configuration-table sexpr)) + (apply build-configuration table + (lambda (host) + (configuration-table-default-host table)) + 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 + + ; build-developer-configuration : tst -> configuration-table (define (build-developer-configuration s-expr) (complete-developer-configuration (directory-part default-configuration-table-path) (parse-configuration-table s-expr))) - - (define (build-developer-configuration/vhosts s-expr) - (complete-developer-configuration/vhosts (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. @@ -65,8 +67,6 @@ [get-configuration (path-string? . -> . configuration-table?)] ; XXX contract [build-developer-configuration (list? . -> . configuration?)] - ; XXX contract - [build-developer-configuration/vhosts (list? . -> . configuration?)] [default-configuration-table-path path?] [update-configuration (configuration? (listof (cons/c symbol? any/c)) . -> . configuration?)] [load-configuration-sexpr (list? . -> . configuration?)] diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/private/configuration.ss index 7ed0bee143..57d0e4551d 100644 --- a/collects/web-server/private/configuration.ss +++ b/collects/web-server/private/configuration.ss @@ -1,5 +1,6 @@ (module configuration mzscheme (require (lib "unitsig.ss") + (lib "kw.ss") (lib "contract.ss")) (require "configuration-structures.ss" "configuration-table-structs.ss" @@ -7,20 +8,6 @@ "cache-table.ss" "../sig.ss" "../response-structs.ss") - - ; : str configuration-table/vhosts -> configuration - (define (complete-developer-configuration/vhosts 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)))) ; : str configuration-table -> configuration (define (complete-configuration base table) @@ -45,7 +32,10 @@ (configuration-table-default-host table))))) ; : configuration-table host-table -> configuration - (define (build-configuration table the-virtual-hosts) + (define/kw (build-configuration table the-virtual-hosts + #:key + [make-servlet-namespace default-make-servlet-namespace]) + (define the-make-servlet-namespace make-servlet-namespace) (unit/sig web-config^ (import) (define port (configuration-table-port table)) @@ -60,44 +50,48 @@ ; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss ; FIX - abstract this out to a namespace library somewhere (ask Robby and Matthew) - (define to-be-copied-module-specs + (define default-to-be-copied-module-specs '(mzscheme ;; allow people (SamTH) to use MrEd primitives from servlets. ;; GregP: putting mred.ss here is a bad idea because it will cause ;; web-server-text to have a dependency on mred ;; JM: We get around it by only doing it if the module is already attached. - (lib "mred.ss" "mred") + ; (lib "mred.ss" "mred") (lib "servlet.ss" "web-server"))) - - ; JBC : added error-handler hack; the right answer is only to transfer the 'mred' - ; module binding when asked to, e.g. by a field in the configuration file. - ; GregP: put this back in if Sam's code breaks - ; (for-each (lambda (x) (with-handlers ([exn:fail? (lambda (exn) 'dont-care)]) - ; ; dynamic-require will fail when running web-server-text. - ; ; maybe a warning message in the exception-handler? - ; (dynamic-require x #f))) - ; to-be-copied-module-specs) - - ;; get the names of those modules. - (define to-be-copied-module-names - (let ([get-name - (lambda (spec) - (if (symbol? spec) - spec - ((current-module-name-resolver) spec #f #f)))]) - (map get-name to-be-copied-module-specs))) ; end stolen - (define (the-make-servlet-namespace) - (let ([server-namespace (current-namespace)] - [new-namespace (make-namespace)]) + (define/kw (make-make-servlet-namespace + #:key + [to-be-copied-module-specs default-to-be-copied-module-specs]) + ; JBC : added error-handler hack; the right answer is only to transfer the 'mred' + ; module binding when asked to, e.g. by a field in the configuration file. + ; GregP: put this back in if Sam's code breaks + ; (for-each (lambda (x) (with-handlers ([exn:fail? (lambda (exn) 'dont-care)]) + ; ; dynamic-require will fail when running web-server-text. + ; ; maybe a warning message in the exception-handler? + ; (dynamic-require x #f))) + ; to-be-copied-module-specs) + + ;; get the names of those modules. + (define to-be-copied-module-names + (let ([get-name + (lambda (spec) + (if (symbol? spec) + spec + ((current-module-name-resolver) spec #f #f)))]) + (map get-name to-be-copied-module-specs))) + ;end stolen + (lambda () + (define server-namespace (current-namespace)) + (define new-namespace (make-namespace)) (parameterize ([current-namespace new-namespace]) (for-each (lambda (name) - (with-handlers ([exn? void]) - (namespace-attach-module server-namespace name))) + (namespace-attach-module server-namespace name)) to-be-copied-module-names) new-namespace))) - + + (define default-make-servlet-namespace (make-make-servlet-namespace)) + ; error-response : nat str str [(cons sym str) ...] -> response ; more here - cache files with a refresh option. ; The server should still start without the files there, so the @@ -222,13 +216,12 @@ expanded-virtual-host-table) default-host))) + (provide ; XXX contract + build-configuration + make-make-servlet-namespace) (provide/contract - [build-configuration (configuration-table? host-table? . -> . configuration?)] [complete-configuration (path-string? configuration-table? . -> . configuration?)] [complete-developer-configuration (path-string? configuration-table? . -> . configuration?)]) - ; XXX contract - (provide - complete-developer-configuration/vhosts) (provide/contract [error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))] ; XXX contract diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 80f3db9486..af0f0caa8b 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -6,38 +6,38 @@ (lib "plt-match.ss") (lib "uri-codec.ss" "net")) (require "../request-structs.ss") - + ;; valid-port? : any/c -> boolean? (define (valid-port? p) (and (integer? p) (exact? p) (<= 1 p 65535))) - + ;; ripped this off from url-unit.ss (define (url-path->string strs) (apply string-append (apply append (map (lambda (s) (list "/" (maybe-join-params s))) strs)))) - + ;; needs to unquote things! (define (maybe-join-params s) (if (string? s) - s - (let ([s (path/param-path s)]) - (if (string? s) - s - (case s - [(same) "."] - [(up) ".."] - [else (error 'maybe-join-params - "bad value from path/param-path: ~e" s)]))))) - + s + (let ([s (path/param-path s)]) + (if (string? s) + s + (case s + [(same) "."] + [(up) ".."] + [else (error 'maybe-join-params + "bad value from path/param-path: ~e" s)]))))) + ;; decompse-request : request -> uri * symbol * string (define (decompose-request req) (let* ([uri (request-uri req)] [method (request-method req)] [path (uri-decode (url-path->string (url-path uri)))]) (values uri method path))) - + ;; network-error: symbol string . values -> void ;; throws a formatted exn:fail:network (define (network-error src fmt . args) @@ -45,8 +45,8 @@ (string->immutable-string (format "~a: ~a" src (apply format fmt args))) (current-continuation-marks)))) - - ;; build-path-unless-absolute : path (or/c string? path?) -> path? + + ;; build-path-unless-absolute : path-string? path-string? -> path? (define (build-path-unless-absolute base path) (if (absolute-path? path) (build-path path) @@ -160,7 +160,7 @@ ; hash-table-empty? : hash-table -> bool (define (hash-table-empty? table) (zero? (hash-table-count table))) - + (provide/contract [url-path->string ((listof (or/c string? path/param?)) . -> . string?)] [extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)] @@ -174,4 +174,4 @@ [directory-part (path? . -> . path?)] [lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)] [exn->string ((or/c exn? any/c) . -> . string?)] - [build-path-unless-absolute (path? (or/c string? path?) . -> . path?)])) + [build-path-unless-absolute (path-string? path-string? . -> . path?)]))