Refactoring namespace library
svn: r6414
This commit is contained in:
parent
377c5b3ad0
commit
871380939c
|
@ -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?)]
|
||||
|
|
37
collects/web-server/configuration/namespace.ss
Normal file
37
collects/web-server/configuration/namespace.ss
Normal file
|
@ -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))
|
|
@ -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))
|
||||
|
|
|
@ -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?)]))
|
|
@ -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)
|
||||
|
|
|
@ -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]
|
||||
|
|
Loading…
Reference in New Issue
Block a user