From 871380939cf2bd4f3d1dc3bc6e76a98060f49682 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 30 May 2007 17:38:53 +0000 Subject: [PATCH] Refactoring namespace library svn: r6414 --- collects/web-server/configuration.ss | 4 +- .../web-server/configuration/namespace.ss | 37 +++++++++++++ .../dispatchers/dispatch-servlets.ss | 5 +- collects/web-server/private/configuration.ss | 52 +------------------ collects/web-server/private/servlet.ss | 4 +- .../dispatch-servlets2.ss | 21 ++++---- 6 files changed, 56 insertions(+), 67 deletions(-) create mode 100644 collects/web-server/configuration/namespace.ss diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 8fc90ee7eb..8dea44184f 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -80,9 +80,7 @@ new-config@) - (provide - make-make-servlet-namespace - load-configuration-sexpr) + (provide load-configuration-sexpr) (provide/contract [complete-configuration (path-string? configuration-table? . -> . configuration?)] [get-configuration (path-string? . -> . configuration-table?)] diff --git a/collects/web-server/configuration/namespace.ss b/collects/web-server/configuration/namespace.ss new file mode 100644 index 0000000000..1a1299e671 --- /dev/null +++ b/collects/web-server/configuration/namespace.ss @@ -0,0 +1,37 @@ +(module namespace mzscheme + (require (lib "kw.ss") + (lib "list.ss")) + + (define default-to-be-copied-module-specs + '(mzscheme + (lib "mred.ss" "mred"))) + + (define/kw (make-make-servlet-namespace + #:key + [to-be-copied-module-specs empty]) + ;; get the names of those modules. + (define (get-name spec) + (if (symbol? spec) + spec + (with-handlers ([exn? (lambda _ #f)]) + ((current-module-name-resolver) spec #f #f)))) + (define to-be-copied-module-names + (map get-name + (append default-to-be-copied-module-specs + to-be-copied-module-specs))) + (lambda/kw (#:key + [additional-specs empty]) + (define server-namespace (current-namespace)) + (define new-namespace (make-namespace)) + (define additional-names (map get-name additional-specs)) + (parameterize ([current-namespace new-namespace]) + (for-each (lambda (name) + (with-handlers ([exn? void]) + (when name + (namespace-attach-module server-namespace name)))) + (append to-be-copied-module-names + additional-names)) + new-namespace))) + + (provide + make-make-servlet-namespace)) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 0e1002c0be..d92cab10c3 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -320,7 +320,10 @@ (lambda (initial-request) (adjust-timeout! timeout) (start initial-request))) - (parameterize ([current-namespace (config:make-servlet-namespace)] + (parameterize ([current-namespace (config:make-servlet-namespace + #:additional-specs + '((lib "servlet.ss" "web-server") + (lib "servlet.ss" "web-server" "private")))] [current-custodian (make-servlet-custodian)]) ; XXX load/use-compiled breaks errortrace (define s (load/use-compiled a-path)) diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/private/configuration.ss index 8dcc75d4c3..1171bc6ad4 100644 --- a/collects/web-server/private/configuration.ss +++ b/collects/web-server/private/configuration.ss @@ -1,12 +1,12 @@ (module configuration mzscheme (require (lib "unit.ss") (lib "kw.ss") - (lib "list.ss") (lib "contract.ss")) (require "configuration-structures.ss" "configuration-table-structs.ss" "util.ss" "cache-table.ss" + "../configuration/namespace.ss" "../configuration/responders.ss" "../web-config-sig.ss") @@ -50,53 +50,6 @@ (define scripts (box (make-cache-table))) (define make-servlet-namespace the-make-servlet-namespace))) - ; 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 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 "servlet.ss" "web-server"))) - ; end stolen - - (define/kw (make-make-servlet-namespace - #:key - [to-be-copied-module-specs empty]) - ; 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 - (with-handlers ([exn? (lambda _ #f)]) - ((current-module-name-resolver) spec #f #f))))]) - (map get-name - (append default-to-be-copied-module-specs - 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]) - (when name - (namespace-attach-module server-namespace name)))) - to-be-copied-module-names) - new-namespace))) - (define default-make-servlet-namespace (make-make-servlet-namespace)) ; apply-default-functions-to-host-table : str host-table -> host @@ -149,8 +102,7 @@ (provide build-configuration - apply-default-functions-to-host-table - make-make-servlet-namespace) + 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 diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 3570ccaa54..a4195ca552 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -17,13 +17,13 @@ (define (get-current-servlet-instance-id) (define instance-id (thread-cell-ref current-servlet-instance-id)) (unless instance-id - (raise (make-exn:fail:servlet:instance "" (current-continuation-marks)))) + (raise (make-exn:fail:servlet:instance "No current servlet instance" (current-continuation-marks)))) instance-id) (define (current-servlet-manager) (define servlet (thread-cell-ref current-servlet)) (unless servlet - (raise (make-exn:fail:servlet:instance "" (current-continuation-marks)))) + (raise (make-exn:fail:servlet:instance "No current servlet" (current-continuation-marks)))) (servlet-manager servlet)) (define (current-servlet-instance-data) diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index bd2a2d804f..8543ad774e 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -12,7 +12,7 @@ "../private/connection-manager.ss" "../private/util.ss" "../private/response.ss" - "../private/configuration.ss" + "../configuration/namespace.ss" "../configuration/responders.ss" "private/utils.ss") @@ -22,18 +22,11 @@ (define top-cust (current-custodian)) - (define make-servlet-namespace - (make-make-servlet-namespace - #:to-be-copied-module-specs - '(mzscheme - (lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api") - (lib "abort-resume.ss" "web-server" "prototype-web-server" "private") - (lib "session.ss" "web-server" "prototype-web-server" "private") - (lib "request.ss" "web-server" "private")))) - (define interface-version 'v1) (define/kw (make #:key [htdocs-path "servlets"] + [make-servlet-namespace + (make-make-servlet-namespace)] [timeouts-servlet-connection (* 60 60 24)] [responders-servlet-loading servlet-loading-responder] @@ -71,7 +64,13 @@ (if a-path (parameterize ([current-directory (directory-part a-path)]) (define cust (make-custodian top-cust)) - (define ns (make-servlet-namespace)) + (define ns (make-servlet-namespace + #:additional-specs + '((lib "servlet.ss" "web-server") + (lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api") + (lib "abort-resume.ss" "web-server" "prototype-web-server" "private") + (lib "session.ss" "web-server" "prototype-web-server" "private") + (lib "request.ss" "web-server" "private")))) (define ses (new-session cust ns (make-session-url uri url-servlet-path))) (parameterize ([current-custodian cust] [current-namespace ns]