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

Moving config:scripts back inside the adt barrier

Browse Source 
svn: r12348
This commit is contained in:
Jay McCarthy 2008-11-07 23:22:11 +00:00
parent c1a10edaff
commit 8a91afa69d
8 changed files with 68 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -17,7 +17,6 @@
(define (mkd p)
(define-values (! u->s)
(servlets:make-cached-url->servlet
(box (make-cache-table))
(lambda _ (values p url0s))
(servlets:make-default-path->servlet)))
(define d

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

@ -107,19 +107,18 @@
(provide/contract
[url->servlet/c contract?]
[make-cached-url->servlet
(-> (box/c cache-table?)
url->path/c
(-> url->path/c
path->servlet/c
(values (-> void)
url->servlet/c))])
(define (make-cached-url->servlet
config:scripts
(define (make-cached-url->servlet
url->path
path->servlet)
(define config:scripts (make-cache-table))
(values (lambda ()
;; This is broken - only out of date or specifically mentioned scripts should be flushed. This destroys persistent state!
(cache-table-clear! (unbox config:scripts)))
(cache-table-clear! config:scripts))
(lambda (uri)
(define-values (servlet-path _)
(with-handlers
@ -128,7 +127,7 @@
(exn-message e)
(exn-continuation-marks e))))])
(url->path uri)))
(cache-table-lookup! (unbox config:scripts)
(cache-table-lookup! config:scripts
(string->symbol (path->string servlet-path))
(lambda () (path->servlet servlet-path))))))

3
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -372,14 +372,13 @@ Equivalent to @scheme[(path? . -> . servlet?)].
@defthing[url->servlet/c contract?]{Equivalent to @scheme[(url? . -> . servlet?)]}
@defproc[(make-cached-url->servlet
[config:scripts (box/c cache-table?)]
[url->path url->path/c]
[path->serlvet path->servlet/c])
(values (-> void)
url->servlet/c)]{
The first return value flushes the cache.
The second is a procedure that uses @scheme[url->path] to resolve the URL to a path, then uses @scheme[path->servlet] to resolve
that path to a servlet, caching the results in @scheme[config:scripts].
that path to a servlet, caching the results in an internal table.
}
@defproc[(make [url->servlet url->servlet/c]

4
collects/web-server/scribblings/web-config-unit.scrbl
View File

@ -25,10 +25,6 @@ Provides contains the following identifiers.
Contains the configuration of individual virtual hosts.
}
@defthing[scripts (box/c (cache-table? path? servlet?))]{
Contains initially loaded servlets.
}
@defthing[initial-connection-timeout integer?]{
Specifies the initial timeout given to a connection.
}

126
collects/web-server/servlet-env.ss
View File

@ -94,67 +94,65 @@
[file-not-found-path (build-path server-root-path "conf" "not-found.html")]
#:mime-types-path
[mime-types-path (build-path server-root-path "mime.types")])
(let*-values
([(standalone-url)
(format "http://localhost:~a~a" the-port servlet-path)]
[(make-servlet-namespace) (make-make-servlet-namespace
#:to-be-copied-module-specs servlet-namespace)]
[(the-scripts) (make-cache-table)]
[(sema) (make-semaphore 0)]
[(servlet)
(parameterize ([current-custodian (make-custodian)]
[current-namespace
(make-servlet-namespace
#:additional-specs
servlets:default-module-specs)])
(servlets:make-v2.servlet servlet-current-directory manager start))]
[(dispatcher)
(sequencer:make
(if quit?
(filter:make
#rx"^/quit$"
(quit-server sema))
(lambda _ (next-dispatcher)))
(filter:make
servlet-regexp
(servlets:make (lambda (url) servlet)))
(let-values ([(clear-cache! url->servlet)
(servlets:make-cached-url->servlet
(box the-scripts)
(fsmap:filter-url->path
#rx"\\.(ss|scm)$"
(fsmap:make-url->valid-path
(fsmap:make-url->path servlets-root)))
(servlets:make-default-path->servlet
#:make-servlet-namespace make-servlet-namespace))])
(servlets:make url->servlet))
(apply sequencer:make
(map (lambda (extra-files-path)
(files:make
#:url->path (fsmap:make-url->path
extra-files-path)
#:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm")))
extra-files-paths))
(files:make
#:url->path (fsmap:make-url->path
(build-path server-root-path "htdocs"))
#:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types"))
#:indices (list "index.html" "index.htm"))
(lift:make (gen-file-not-found-responder file-not-found-path)))]
[(shutdown-server)
(serve #:dispatch dispatcher
#:listen-ip listen-ip
#:port the-port)])
(when launch-browser?
((send-url) standalone-url #t))
(printf "Your Web application is running at ~a.~n" standalone-url)
(printf "Click 'Stop' at any time to terminate the Web Server.~n")
(with-handlers
([exn:break?
(lambda (exn)
(printf "~nWeb Server stopped.~n")
(shutdown-server))])
(semaphore-wait/enable-break sema))
; We shouldn't get here, because nothing posts to the semaphore. But just in case...
(shutdown-server)))
(define standalone-url
(format "http://localhost:~a~a" the-port servlet-path))
(define make-servlet-namespace
(make-make-servlet-namespace
#:to-be-copied-module-specs servlet-namespace))
(define sema (make-semaphore 0))
(define servlet
(parameterize ([current-custodian (make-custodian)]
[current-namespace
(make-servlet-namespace
#:additional-specs
servlets:default-module-specs)])
(servlets:make-v2.servlet servlet-current-directory manager start)))
(define dispatcher
(sequencer:make
(if quit?
(filter:make
#rx"^/quit$"
(quit-server sema))
(lambda _ (next-dispatcher)))
(filter:make
servlet-regexp
(servlets:make (lambda (url) servlet)))
(let-values ([(clear-cache! url->servlet)
(servlets:make-cached-url->servlet
(fsmap:filter-url->path
#rx"\\.(ss|scm)$"
(fsmap:make-url->valid-path
(fsmap:make-url->path servlets-root)))
(servlets:make-default-path->servlet
#:make-servlet-namespace make-servlet-namespace))])
(servlets:make url->servlet))
(apply sequencer:make
(map (lambda (extra-files-path)
(files:make
#:url->path (fsmap:make-url->path
extra-files-path)
#:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm")))
extra-files-paths))
(files:make
#:url->path (fsmap:make-url->path
(build-path server-root-path "htdocs"))
#:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types"))
#:indices (list "index.html" "index.htm"))
(lift:make (gen-file-not-found-responder file-not-found-path))))
(define shutdown-server
(serve #:dispatch dispatcher
#:listen-ip listen-ip
#:port the-port))
(when launch-browser?
((send-url) standalone-url #t))
(printf "Your Web application is running at ~a.~n" standalone-url)
(printf "Click 'Stop' at any time to terminate the Web Server.~n")
(with-handlers
([exn:break?
(lambda (exn)
(printf "~nWeb Server stopped.~n")
(shutdown-server))])
(semaphore-wait/enable-break sema))
; We shouldn't get here, because nothing posts to the semaphore. But just in case...
(shutdown-server))

1
collects/web-server/web-config-sig.ss
View File

@ -2,7 +2,6 @@
max-waiting
virtual-hosts
scripts
initial-connection-timeout
port
listen-ip

1
collects/web-server/web-config-unit.ss
View File

@ -88,7 +88,6 @@
(define listen-ip the-listen-ip)
(define initial-connection-timeout (configuration-table-initial-connection-timeout table))
(define virtual-hosts the-virtual-hosts)
(define scripts (box (make-cache-table)))
(define make-servlet-namespace the-make-servlet-namespace)))
; apply-default-functions-to-host-table : str host-table -> host

1
collects/web-server/web-server-unit.ss
View File

@ -77,7 +77,6 @@
((responders-collect-garbage (host-responders host-info)))))
(let-values ([(clear-cache! url->servlet)
(servlets:make-cached-url->servlet
config:scripts
(fsmap:filter-url->path
#rx"\\.(ss|scm)$"
(fsmap:make-url->valid-path