suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactoring namespace library

Browse Source 
svn: r6414
This commit is contained in:
Jay McCarthy 2007-05-30 17:38:53 +00:00
parent 377c5b3ad0
commit 871380939c
6 changed files with 56 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/web-server/configuration.ss
View File

@ -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
View 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))

5
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -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))

52
collects/web-server/private/configuration.ss
View File

@ -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?)]))

4
collects/web-server/private/servlet.ss
View File

@ -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)

21
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -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]