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

Adding web-cells

Browse Source 
svn: r1095
This commit is contained in:
Jay McCarthy 2005-10-16 17:08:25 +00:00
parent 99c1f896da
commit 1c99e77b91
3 changed files with 649 additions and 391 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

760
collects/web-server/dispatch-servlets.ss
View File

@ -19,384 +19,386 @@
(define interface-version 'v1) (define interface-version 'v1)
(define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace) (define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace)
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; SERVING SERVLETS ;; SERVING SERVLETS
;; servlet-content-producer: connection request host -> void ;; servlet-content-producer: connection request host -> void
(define (servlet-content-producer conn req host-info) (define (servlet-content-producer conn req host-info)
(let ([meth (request-method req)]) (let ([meth (request-method req)])
(if (eq? meth 'head) (if (eq? meth 'head)
(output-response/method (output-response/method
conn conn
(make-response/full (make-response/full
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
'() (list "ignored")) '() (list "ignored"))
meth) meth)
(let ([uri (request-uri req)]) (let ([uri (request-uri req)])
(set-request-bindings/raw! (set-request-bindings/raw!
req req
(read-bindings/handled conn meth uri (request-headers req) (read-bindings/handled conn meth uri (request-headers req)
host-info)) host-info))
(cond (cond
[(continuation-url? uri) [(continuation-url? uri)
=> (lambda (k-ref) => (lambda (k-ref)
(invoke-servlet-continuation conn req k-ref host-info))] (invoke-servlet-continuation conn req k-ref host-info))]
[else [else
(servlet-content-producer/path conn req host-info uri)]))))) (servlet-content-producer/path conn req host-info uri)])))))
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string)) ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
;; read the bindings and handle any exceptions ;; read the bindings and handle any exceptions
(define (read-bindings/handled conn meth uri headers host-info) (define (read-bindings/handled conn meth uri headers host-info)
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (e)
(output-response/method (output-response/method
conn conn
;((responders-protocol (host-responders host-info)) ;((responders-protocol (host-responders host-info))
; (exn-message e)) ; (exn-message e))
((responders-servlet-loading (host-responders ((responders-servlet-loading (host-responders
host-info)) host-info))
uri e) uri e)
meth) meth)
'())]) '())])
(read-bindings conn meth uri headers))) (read-bindings conn meth uri headers)))
;; servlet-content-producer/path: connection request host url -> void ;; servlet-content-producer/path: connection request host url -> void
;; This is not a continuation url so the loading behavior is determined ;; This is not a continuation url so the loading behavior is determined
;; by the url path. Build the servlet path and then load the servlet ;; by the url path. Build the servlet path and then load the servlet
(define (servlet-content-producer/path conn req host-info uri) (define (servlet-content-producer/path conn req host-info uri)
(with-handlers (;; couldn't find the servlet (with-handlers (;; couldn't find the servlet
[exn:fail:filesystem:exists:servlet? [exn:fail:filesystem:exists:servlet?
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((responders-file-not-found (host-responders ((responders-file-not-found (host-responders
host-info)) host-info))
(request-uri req)) (request-uri req))
(request-method req)))] (request-method req)))]
;; servlet won't load (e.g. syntax error) ;; servlet won't load (e.g. syntax error)
[(lambda (x) #t) [(lambda (x) #t)
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((responders-servlet-loading ((responders-servlet-loading
(host-responders host-info)) (host-responders host-info))
uri the-exn) uri the-exn)
(request-method req)))]) (request-method req)))])
(let ([sema (make-semaphore 0)] (let ([sema (make-semaphore 0)]
[last-inst (thread-cell-ref current-servlet-instance)]) [last-inst (thread-cell-ref current-servlet-instance)])
(let/cc suspend (let/cc suspend
(let* ([servlet-custodian (make-servlet-custodian)] ; Create the session frame
[inst (create-new-instance! (with-frame
config:instances servlet-custodian (let* ([servlet-custodian (make-servlet-custodian)]
(make-execution-context [inst (create-new-instance!
conn req (lambda () (suspend #t))) config:instances servlet-custodian
sema (make-execution-context
(start-timer 0 void))] conn req (lambda () (suspend #t)))
[real-servlet-path (with-handlers ([void (lambda (e) sema
(raise (make-exn:fail:filesystem:exists:servlet (start-timer 0 void))]
(exn-message e) [real-servlet-path (with-handlers ([void (lambda (e)
(exn-continuation-marks e))))]) (raise (make-exn:fail:filesystem:exists:servlet
(url-path->path (exn-message e)
(paths-servlet (host-paths host-info)) (exn-continuation-marks e))))])
(url-path->string (url-path uri))))] (url-path->path
[servlet-exit-handler (make-servlet-exit-handler inst)]) (paths-servlet (host-paths host-info))
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] (url-path->string (url-path uri))))]
[current-custodian servlet-custodian] [servlet-exit-handler (make-servlet-exit-handler inst)])
[current-servlet-continuation-expiration-handler (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
(make-default-servlet-continuation-expiration-handler host-info)] [current-custodian servlet-custodian]
[exit-handler servlet-exit-handler]) [current-servlet-continuation-expiration-handler
(thread-cell-set! current-servlet-instance inst) (make-default-servlet-continuation-expiration-handler host-info)]
(let (;; timer thread must be within the dynamic extent of [exit-handler servlet-exit-handler])
;; servlet custodian (thread-cell-set! current-servlet-instance inst)
[time-bomb (start-timer (timeouts-default-servlet (let (;; timer thread must be within the dynamic extent of
(host-timeouts host-info)) ;; servlet custodian
(lambda () [time-bomb (start-timer (timeouts-default-servlet
(servlet-exit-handler #f)))] (host-timeouts host-info))
;; any resources (e.g. threads) created when the (lambda ()
;; servlet is loaded should be within the dynamic (servlet-exit-handler #f)))]
;; extent of the servlet custodian ;; any resources (e.g. threads) created when the
[the-servlet (cached-load real-servlet-path)]) ;; servlet is loaded should be within the dynamic
(parameterize ([current-namespace (servlet-namespace the-servlet)]) ;; extent of the servlet custodian
(set-servlet-instance-timer! inst time-bomb) [the-servlet (cached-load real-servlet-path)])
(with-handlers ([(lambda (x) #t) (parameterize ([current-namespace (servlet-namespace the-servlet)])
(make-servlet-exception-handler inst host-info)]) (set-servlet-instance-timer! inst time-bomb)
;; Two possibilities: (with-handlers ([(lambda (x) #t)
;; - module servlet. start : Request -> Void handles (make-servlet-exception-handler inst host-info)])
;; output-response via send/finish, etc. ;; Two possibilities:
;; - unit/sig or simple xexpr servlet. These must produce a ;; - module servlet. start : Request -> Void handles
;; response, which is then output by the server. ;; output-response via send/finish, etc.
;; Here, we do not know if the servlet was a module, ;; - unit/sig or simple xexpr servlet. These must produce a
;; unit/sig, or Xexpr; we do know whether it produces a ;; response, which is then output by the server.
;; response. ;; Here, we do not know if the servlet was a module,
(let ([r ((servlet-handler the-servlet) req)]) ;; unit/sig, or Xexpr; we do know whether it produces a
(when (response? r) ;; response.
(send/back r))))))))) (let ([r ((servlet-handler the-servlet) req)])
(thread-cell-set! current-servlet-instance last-inst) (when (response? r)
(semaphore-post sema)))) (send/back r))))))))))
(thread-cell-set! current-servlet-instance last-inst)
;; make-servlet-exit-handler: servlet-instance -> alpha -> void (semaphore-post sema))))
;; exit handler for a servlet
(define (make-servlet-exit-handler inst) ;; make-servlet-exit-handler: servlet-instance -> alpha -> void
(lambda (x) ;; exit handler for a servlet
(remove-instance! config:instances inst) (define (make-servlet-exit-handler inst)
(kill-connection! (lambda (x)
(execution-context-connection (remove-instance! config:instances inst)
(servlet-instance-context inst))) (kill-connection!
(custodian-shutdown-all (servlet-instance-custodian inst)))) (execution-context-connection
(servlet-instance-context inst)))
;; make-default-server-continuation-expiration-handler : host -> (request -> response) (custodian-shutdown-all (servlet-instance-custodian inst))))
(define (make-default-servlet-continuation-expiration-handler host-info)
(lambda (req) ;; make-default-server-continuation-expiration-handler : host -> (request -> response)
(send/back (define (make-default-servlet-continuation-expiration-handler host-info)
(lambda (req)
(send/back
((responders-file-not-found (host-responders
host-info))
(request-uri req)))))
;; make-default-server-instance-expiration-handler : host -> (request -> response)
(define (make-default-servlet-instance-expiration-handler host-info)
(lambda (req)
((responders-file-not-found (host-responders ((responders-file-not-found (host-responders
host-info)) host-info))
(request-uri req))))) (request-uri req))))
;; make-servlet-exception-handler: host -> exn -> void
;; make-default-server-instance-expiration-handler : host -> (request -> response) ;; This exception handler traps all unhandled servlet exceptions
(define (make-default-servlet-instance-expiration-handler host-info) ;; * Must occur within the dynamic extent of the servlet
(lambda (req) ;; custodian since several connection custodians will typically
((responders-file-not-found (host-responders ;; be shutdown during the dynamic extent of a continuation
host-info)) ;; * Use the connection from the current-servlet-context in case
(request-uri req)))) ;; the exception is raised while invoking a continuation.
;; * Use the suspend from the servlet-instanct-context which is
;; make-servlet-exception-handler: host -> exn -> void ;; closed over the current tcp ports which may need to be
;; This exception handler traps all unhandled servlet exceptions ;; closed for an http 1.0 request.
;; * Must occur within the dynamic extent of the servlet ;; * Also, suspend will post to the semaphore so that future
;; custodian since several connection custodians will typically ;; requests won't be blocked.
;; be shutdown during the dynamic extent of a continuation ;; * This fixes PR# 7066
;; * Use the connection from the current-servlet-context in case (define (make-servlet-exception-handler inst host-info)
;; the exception is raised while invoking a continuation. (lambda (the-exn)
;; * Use the suspend from the servlet-instanct-context which is (let* ([ctxt (servlet-instance-context inst)]
;; closed over the current tcp ports which may need to be [req (execution-context-request ctxt)]
;; closed for an http 1.0 request. [resp ((responders-servlet (host-responders
;; * Also, suspend will post to the semaphore so that future host-info))
;; requests won't be blocked. (request-uri req)
;; * This fixes PR# 7066 the-exn)])
(define (make-servlet-exception-handler inst host-info) ;; Don't handle twice
(lambda (the-exn) (with-handlers ([exn:fail? (lambda (exn) (void))])
(let* ([ctxt (servlet-instance-context inst)] (output-response/method
[req (execution-context-request ctxt)] (execution-context-connection ctxt)
[resp ((responders-servlet (host-responders resp (request-method req)))
host-info)) ((execution-context-suspend ctxt)))))
(request-uri req)
the-exn)]) ;; path -> path
;; Don't handle twice ;; The actual servlet's parent directory.
(with-handlers ([exn:fail? (lambda (exn) (void))]) (define (get-servlet-base-dir servlet-path)
(output-response/method (let loop ((path servlet-path))
(execution-context-connection ctxt) (let-values ([(base name must-be-dir?) (split-path path)])
resp (request-method req))) (if must-be-dir?
((execution-context-suspend ctxt))))) (or (and (directory-exists? path) path)
(loop base))
;; path -> path (or (and (directory-exists? base) base)
;; The actual servlet's parent directory. (loop base))))))
(define (get-servlet-base-dir servlet-path)
(let loop ((path servlet-path)) ;; invoke-servlet-continuation: connection request continuation-reference
(let-values ([(base name must-be-dir?) (split-path path)]) ;; host -> void
(if must-be-dir? ;; pull the continuation out of the table and apply it
(or (and (directory-exists? path) path) (define (invoke-servlet-continuation conn req k-ref host-info)
(loop base)) (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
(or (and (directory-exists? base) base) (let* ([uri (request-uri req)]
(loop base)))))) [real-servlet-path (url-path->path
(paths-servlet (host-paths host-info))
;; invoke-servlet-continuation: connection request continuation-reference (url-path->string (url-path uri)))]
;; host -> void [the-servlet (cached-load real-servlet-path)])
;; pull the continuation out of the table and apply it (parameterize ([current-custodian (servlet-custodian the-servlet)])
(define (invoke-servlet-continuation conn req k-ref host-info) (let ([default-servlet-instance-expiration-handler
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) (make-default-servlet-instance-expiration-handler host-info)]
(let* ([uri (request-uri req)] [default-servlet-continuation-expiration-handler
[real-servlet-path (url-path->path (make-default-servlet-continuation-expiration-handler host-info)]
(paths-servlet (host-paths host-info)) [last-inst (thread-cell-ref current-servlet-instance)])
(url-path->string (url-path uri)))] (thread-cell-set! current-servlet-instance #f)
[the-servlet (cached-load real-servlet-path)]) (with-handlers ([exn:servlet:instance?
(parameterize ([current-custodian (servlet-custodian the-servlet)]) (lambda (the-exn)
(let ([default-servlet-instance-expiration-handler (output-response/method
(make-default-servlet-instance-expiration-handler host-info)] conn
[default-servlet-continuation-expiration-handler ((servlet-instance-expiration-handler the-servlet) req)
(make-default-servlet-continuation-expiration-handler host-info)] (request-method req)))]
[last-inst (thread-cell-ref current-servlet-instance)]) [exn:servlet:continuation?
(thread-cell-set! current-servlet-instance #f) (lambda (the-exn)
(with-handlers ([exn:servlet:instance? ((exn:servlet:continuation-expiration-handler the-exn) req))]
(lambda (the-exn) [exn:servlet:no-current-instance?
(output-response/method (lambda (the-exn)
conn (output-response/method
((servlet-instance-expiration-handler the-servlet) req) conn
(request-method req)))] ((default-servlet-instance-expiration-handler) req)
[exn:servlet:continuation? (request-method req)))])
(lambda (the-exn) (let* ([inst
((exn:servlet:continuation-expiration-handler the-exn) req))] (hash-table-get config:instances uk-instance
[exn:servlet:no-current-instance? (lambda ()
(lambda (the-exn) (raise
(output-response/method (make-exn:servlet:instance
conn "" (current-continuation-marks)))))]
((default-servlet-instance-expiration-handler) req) [k-table
(request-method req)))]) (servlet-instance-k-table inst)])
(let* ([inst (let/cc suspend
(hash-table-get config:instances uk-instance ; We don't use call-with-semaphore or dynamic-wind because we
(lambda () ; always call a continuation. The exit-handler above ensures that
(raise ; the post is done.
(make-exn:servlet:instance (semaphore-wait (servlet-instance-mutex inst))
"" (current-continuation-marks)))))] (thread-cell-set! current-servlet-instance inst)
[k-table (set-servlet-instance-context!
(servlet-instance-k-table inst)]) inst
(let/cc suspend (make-execution-context
; We don't use call-with-semaphore or dynamic-wind because we conn req (lambda () (suspend #t))))
; always call a continuation. The exit-handler above ensures that (increment-timer (servlet-instance-timer inst)
; the post is done. (servlet-connection-interval-timeout the-servlet))
(semaphore-wait (servlet-instance-mutex inst)) (let-values ([(k k-expiration-handler k-salt)
(thread-cell-set! current-servlet-instance inst) (apply values
(set-servlet-instance-context! (hash-table-get
inst k-table uk-id
(make-execution-context (lambda ()
conn req (lambda () (suspend #t)))) (raise
(increment-timer (servlet-instance-timer inst) (make-exn:servlet:continuation
(servlet-connection-interval-timeout the-servlet)) "" (current-continuation-marks)
(let-values ([(k k-expiration-handler k-salt) default-servlet-continuation-expiration-handler)))))])
(apply values (if (and k (= k-salt uk-salt))
(hash-table-get (k req)
k-table uk-id (raise
(lambda () (make-exn:servlet:continuation
(raise "" (current-continuation-marks)
(make-exn:servlet:continuation k-expiration-handler)))))
"" (current-continuation-marks) (semaphore-post (servlet-instance-mutex inst))))
default-servlet-continuation-expiration-handler)))))]) (thread-cell-set! current-servlet-instance last-inst))))))
(if (and k (= k-salt uk-salt))
(k req) ;; ************************************************************
(raise ;; ************************************************************
(make-exn:servlet:continuation ;; Paul's ugly loading code:
"" (current-continuation-marks)
k-expiration-handler))))) ;; cached-load : path -> script, namespace
(semaphore-post (servlet-instance-mutex inst)))) ;; timestamps are no longer checked for performance. The cache must be explicitly
(thread-cell-set! current-servlet-instance last-inst)))))) ;; refreshed (see dispatch).
(define (cached-load servlet-path)
;; ************************************************************ (let ([entry-id (string->symbol (path->string servlet-path))])
;; ************************************************************ (cache-table-lookup!
;; Paul's ugly loading code: (unbox config:scripts)
entry-id
;; cached-load : path -> script, namespace (lambda ()
;; timestamps are no longer checked for performance. The cache must be explicitly (reload-servlet-script servlet-path)))))
;; refreshed (see dispatch).
(define (cached-load servlet-path) ;; exn:i/o:filesystem:servlet-not-found =
(let ([entry-id (string->symbol (path->string servlet-path))]) ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(cache-table-lookup! (define-struct (exn:fail:filesystem:exists:servlet
(unbox config:scripts) exn:fail:filesystem:exists) ())
entry-id
(lambda () ;; reload-servlet-script : str -> cache-entry
(reload-servlet-script servlet-path))))) ;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
(define (reload-servlet-script servlet-filename)
;; exn:i/o:filesystem:servlet-not-found = (cond
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) [(load-servlet/path servlet-filename)
(define-struct (exn:fail:filesystem:exists:servlet => (lambda (entry)
exn:fail:filesystem:exists) ()) entry)]
[else
;; reload-servlet-script : str -> cache-entry (raise (make-exn:fail:filesystem:exists:servlet
;; The servlet is not cached in the servlet-table, so reload it from the filesystem. (string->immutable-string (format "Couldn't find ~a" servlet-filename))
(define (reload-servlet-script servlet-filename) (current-continuation-marks) ))]))
(cond
[(load-servlet/path servlet-filename) ;; load-servlet/path path -> (union #f cache-entry)
=> (lambda (entry) ;; given a string path to a filename attempt to load a servlet
entry)] ;; A servlet-file will contain either
[else ;;;; A signed-unit-servlet
(raise (make-exn:fail:filesystem:exists:servlet ;;;; A module servlet, currently only 'v1
(string->immutable-string (format "Couldn't find ~a" servlet-filename)) ;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
(current-continuation-marks) ))])) ;;;; A response
(define (load-servlet/path a-path)
;; load-servlet/path path -> (union #f cache-entry) (define (v0.servlet->v1.lambda servlet)
;; given a string path to a filename attempt to load a servlet (lambda (initial-request)
;; A servlet-file will contain either (invoke-unit/sig servlet servlet^)))
;;;; A signed-unit-servlet (define (v0.response->v1.lambda response-path response)
;;;; A module servlet, currently only 'v1 (letrec ([go (lambda ()
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.) (begin
;;;; A response (set! go (lambda () (load/use-compiled a-path)))
(define (load-servlet/path a-path) response))])
(define (v0.servlet->v1.lambda servlet) (lambda (initial-request) (go))))
(lambda (initial-request) (define (v1.module->v1.lambda timeout start)
(invoke-unit/sig servlet servlet^))) (lambda (initial-request)
(define (v0.response->v1.lambda response-path response) (adjust-timeout! timeout)
(letrec ([go (lambda () (start initial-request)))
(begin (let ([servlet-custodian (make-servlet-custodian)])
(set! go (lambda () (load/use-compiled a-path))) (parameterize ([current-namespace (config:make-servlet-namespace)]
response))]) [current-custodian servlet-custodian])
(lambda (initial-request) (go)))) (and (file-exists? a-path)
(define (v1.module->v1.lambda timeout start) (let ([s (load/use-compiled a-path)])
(lambda (initial-request) (cond
(adjust-timeout! timeout) ;; signed-unit servlet
(start initial-request))) ; MF: I'd also like to test that s has the correct import signature.
(let ([servlet-custodian (make-servlet-custodian)]) [(unit/sig? s)
(parameterize ([current-namespace (config:make-servlet-namespace)] (make-servlet (v0.servlet->v1.lambda s)
[current-custodian servlet-custodian]) servlet-custodian
(and (file-exists? a-path) (current-namespace)
(let ([s (load/use-compiled a-path)]) (timeouts-default-servlet
(cond (host-timeouts host-info))
;; signed-unit servlet (make-default-servlet-instance-expiration-handler host-info))]
; MF: I'd also like to test that s has the correct import signature. ; FIX - reason about exceptions from dynamic require (catch and report if not already)
[(unit/sig? s) ;; module servlet
(make-servlet (v0.servlet->v1.lambda s) [(void? s)
servlet-custodian (let* ([module-name `(file ,(path->string a-path))]
(current-namespace) [version (dynamic-require module-name 'interface-version)])
(timeouts-default-servlet (case version
(host-timeouts host-info)) [(v1)
(make-default-servlet-instance-expiration-handler host-info))] (let ([timeout (dynamic-require module-name 'timeout)]
; FIX - reason about exceptions from dynamic require (catch and report if not already) [start (dynamic-require module-name 'start)])
;; module servlet (make-servlet (v1.module->v1.lambda timeout start)
[(void? s) servlet-custodian
(let* ([module-name `(file ,(path->string a-path))] (current-namespace)
[version (dynamic-require module-name 'interface-version)]) (timeouts-default-servlet
(case version (host-timeouts host-info))
[(v1) (make-default-servlet-instance-expiration-handler host-info)))]
(let ([timeout (dynamic-require module-name 'timeout)] [(v2-transitional) ; XXX: Undocumented
[start (dynamic-require module-name 'start)]) (let ([timeout (dynamic-require module-name 'timeout)]
(make-servlet (v1.module->v1.lambda timeout start) [instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)]
servlet-custodian [start (dynamic-require module-name 'start)])
(current-namespace) (make-servlet (v1.module->v1.lambda timeout start)
(timeouts-default-servlet servlet-custodian
(host-timeouts host-info)) (current-namespace)
(make-default-servlet-instance-expiration-handler host-info)))] timeout
[(v2-transitional) ; XXX: Undocumented instance-expiration-handler))]
(let ([timeout (dynamic-require module-name 'timeout)] [else
[instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)] (raise (format "unknown servlet version ~e" version))]))]
[start (dynamic-require module-name 'start)]) ;; response
(make-servlet (v1.module->v1.lambda timeout start) [(response? s)
servlet-custodian (make-servlet (v0.response->v1.lambda s a-path)
(current-namespace) servlet-custodian
timeout (current-namespace)
instance-expiration-handler))] (timeouts-default-servlet
[else (host-timeouts host-info))
(raise (format "unknown servlet version ~e" version))]))] (make-default-servlet-instance-expiration-handler host-info))]
;; response [else
[(response? s) (raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))))))
(make-servlet (v0.response->v1.lambda s a-path)
servlet-custodian (define servlet-bin?
(current-namespace) (let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")])
(timeouts-default-servlet (lambda (str)
(host-timeouts host-info)) (regexp-match svt-bin-re str))))
(make-default-servlet-instance-expiration-handler host-info))]
[else ;; return dispatcher
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))) (lambda (conn req)
(let-values ([(uri method path) (decompose-request req)])
(define servlet-bin? (cond [(string=? "/conf/refresh-servlets" path)
(let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")]) ;; more here - this is broken - only out of date or specifically mentioned
(lambda (str) ;; scripts should be flushed. This destroys persistent state!
(regexp-match svt-bin-re str)))) (cache-table-clear! (unbox config:scripts))
(output-response/method
;; return dispatcher conn
(lambda (conn req) ((responders-servlets-refreshed (host-responders host-info)))
(let-values ([(uri method path) (decompose-request req)]) method)]
(cond [(string=? "/conf/refresh-servlets" path) [(servlet-bin? path)
;; more here - this is broken - only out of date or specifically mentioned (adjust-connection-timeout!
;; scripts should be flushed. This destroys persistent state! conn
(cache-table-clear! (unbox config:scripts)) (timeouts-servlet-connection (host-timeouts host-info)))
(output-response/method ;; more here - make timeouts proportional to size of bindings
conn (servlet-content-producer conn req host-info)]
((responders-servlets-refreshed (host-responders host-info))) [else
method)] (next-dispatcher)])))))
[(servlet-bin? path)
(adjust-connection-timeout!
conn
(timeouts-servlet-connection (host-timeouts host-info)))
;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info)]
[else
(next-dispatcher)])))))

35
collects/web-server/servlet.ss
View File

@ -6,11 +6,13 @@
"response.ss" "response.ss"
"servlet-helpers.ss" "servlet-helpers.ss"
"xexpr-callback.ss" "xexpr-callback.ss"
"timer.ss") "timer.ss"
"web-cells.ss")
;; Weak contracts: the input is checked in output-response, and a message is ;; Weak contracts: the input is checked in output-response, and a message is
;; sent directly to the client (Web browser) instead of the terminal/log. ;; sent directly to the client (Web browser) instead of the terminal/log.
(provide/contract (provide/contract
[redirect/get (-> request?)]
[adjust-timeout! (number? . -> . any)] [adjust-timeout! (number? . -> . any)]
[send/back (any/c . -> . any)] [send/back (any/c . -> . any)]
[send/finish (any/c . -> . any)] [send/finish (any/c . -> . any)]
@ -18,14 +20,22 @@
[send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)] [send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)]
;;; validate-xexpr/callback is not checked anywhere: ;;; validate-xexpr/callback is not checked anywhere:
[send/suspend/callback (xexpr/callback? . -> . any)]) [send/suspend/callback (xexpr/callback? . -> . any)])
(provide (provide
clear-continuation-table! clear-continuation-table!
send/suspend/dispatch send/suspend/dispatch
current-servlet-continuation-expiration-handler current-servlet-continuation-expiration-handler
(all-from "web-cells.ss")
(all-from "servlet-helpers.ss") (all-from "servlet-helpers.ss")
(all-from "xexpr-callback.ss")) (all-from "xexpr-callback.ss"))
;; ************************************************************
;; HIGHER-LEVEL EXPORTS
; redirect/get : -> request
(define (redirect/get)
(send/suspend (lambda (k-url) (redirect-to k-url temporarily))))
;; ************************************************************ ;; ************************************************************
;; EXPORTS ;; EXPORTS
@ -72,16 +82,17 @@
;; send a response and apply the continuation to the next request ;; send a response and apply the continuation to the next request
(define send/suspend (define send/suspend
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/cc k (with-frame-after
(let* ([inst (get-current-servlet-instance)] (let/cc k
[ctxt (servlet-instance-context inst)] (let* ([inst (get-current-servlet-instance)]
[k-url (store-continuation! [ctxt (servlet-instance-context inst)]
k expiration-handler [k-url (store-continuation!
(request-uri (execution-context-request ctxt)) k expiration-handler
inst)] (request-uri (execution-context-request ctxt))
[response (response-generator k-url)]) inst)]
(output-response (execution-context-connection ctxt) response) [response (response-generator k-url)])
((execution-context-suspend ctxt)))))) (output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt)))))))
;; send/forward: (url -> response) [(request -> response)] -> request ;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend ;; clear the continuation table, then behave like send/suspend

245
collects/web-server/web-cells.ss Normal file
View File

@ -0,0 +1,245 @@
(module web-cells mzscheme
(require (lib "struct.ss"))
(define-struct (exn:fail:frame:top exn) ())
(define (exn:fail:frame:top-raise)
(raise (make-exn:fail:frame:top
"Reached top of stack"
(current-continuation-marks))))
(provide exn:fail:frame:top?)
;; frames
(define-struct frame ())
(define-struct (frame:empty frame) ())
; frame:ns : (alist * (box frame) * namespace)
(define-struct (frame:ns frame) (annotations boxed-parent namespace))
; frame:ns?/raise : frame -> frame
(define (frame:ns?/raise f)
(if (frame:ns? f)
f
(exn:fail:frame:top-raise)))
; make-frame/parent : (box frame) -> frame:ns
(define (make-frame/parent parent-frame-box)
(make-frame:ns (list) parent-frame-box (make-namespace 'empty)))
; search-frames : frame:ns (frame:ns -> boolean?) -> frame
; Returns the first frame in the stack that matches the predicate
(define (search-frames a-frame predicate?)
(if (predicate? a-frame)
a-frame
(search-frames (frame:ns?/raise
(unbox (frame:ns-boxed-parent a-frame)))
predicate?)))
; frame-ref : frame:ns symbol -> any
; Lookups up the variable in the frame and its parent(s)
(define (frame-ref a-frame var)
#;(printf "~S~n" (list (namespace-mapped-symbols (frame:ns-namespace a-frame)) var))
(namespace-variable-value
var #f
(lambda ()
(frame-ref (frame:ns?/raise
(unbox (frame:ns-boxed-parent a-frame)))
var))
(frame:ns-namespace a-frame)))
; frame-set? : frame:ns symbol -> boolean
(define (frame-set? a-frame var)
(not
(not
(namespace-variable-value
var #f
(lambda () #f)
(frame:ns-namespace a-frame)))))
; frame-set! : frame:ns symbol any -> void
; Sets the variable in the frame to a value
(define (frame-set! a-frame var val)
(namespace-set-variable-value!
var val
#t (frame:ns-namespace a-frame)))
;; frame stacks
(define *global-root-id* (gensym))
(define *session-root-id* (gensym))
; *frame-stack* : (box frame)
(define *frame-stack*
(make-parameter
(box (copy-struct frame:ns (make-frame/parent (box (make-frame:empty)))
[frame:ns-annotations (list (cons *global-root-id* #t))]))))
; annotation-present? : symbol frame:ns -> boolean
(define (annotation-present? i a-frame)
(not (not (assq i (frame:ns-annotations a-frame)))))
; global-root? : frame:ns -> boolean
(define (global-root? a-frame)
(annotation-present? *global-root-id* a-frame))
; session-root? : frame:ns -> boolean
(define (session-root? a-frame)
(annotation-present? *session-root-id* a-frame))
; make-frame/top : -> frame:ns
(define (make-frame/top)
(let* ([cur-top-box (*frame-stack*)]
[cur-top (unbox cur-top-box)])
(cond
#;[(not (frame:ns? cur-top))
; Construct global
(copy-struct frame:ns (make-frame/parent cur-top-box)
[frame:ns-annotations (list (cons *global-root-id* #t))])]
[(global-root? cur-top)
; Construct session
(copy-struct frame:ns (make-frame/parent cur-top-box)
[frame:ns-annotations (list (cons *session-root-id* #t))])]
[else
; Construct normal
(make-frame/parent cur-top-box)])))
; push-frame! : -> void
; Pushs a new frame onto the session stack
(define (push-frame!)
(*frame-stack* (box (make-frame/top))))
; pop-frame! : -> void
; Pops the frame from the stack
(define (pop-frame!)
(*frame-stack* (frame:ns-boxed-parent (unbox (*frame-stack*)))))
; save-stack/push/return : (-> 'a) -> 'a
; Pushes a frame after the thunk's execution with the same parent as the call site
(define (save-stack/push/return thunk)
(let ([initial-stack (*frame-stack*)])
(begin0 (thunk)
(*frame-stack* initial-stack)
(push-frame!))))
; syntax version of above
(define-syntax with-frame-after
(syntax-rules ()
[(_ body ...)
(save-stack/push/return (lambda () body ...))]))
; parameterized-push : (-> 'a) -> 'a
(define (parameterized-push thunk)
(parameterize ([*frame-stack* (box (make-frame/top))])
(thunk)))
; syntax version of above
(define-syntax with-frame
(syntax-rules ()
[(_ body ...)
(parameterized-push (lambda () body ...))]))
; search-stack : (frame -> boolean) -> frame
(define (search-stack predicate?)
(search-frames (frame:ns?/raise (unbox (*frame-stack*)))
predicate?))
; cells
(define-struct cell (id))
(define-struct (cell:global cell) ())
(define-struct (cell:session cell) ())
(define-struct (cell:local cell) ())
; ext:make-'a 'b -> 'a
(define (ext:make-cell:global default)
(let ([new-name (gensym)])
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:global new-name)))
(define (ext:make-cell:session default)
(let ([new-name (gensym)])
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:session new-name)))
(define (ext:make-cell:local default)
(let ([new-name (gensym)])
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:local new-name)))
; cell:global-ref : cell:global -> any
; returns the value of the global cell
(define (cell:global-ref gc)
(frame-ref (search-stack global-root?)
(cell-id gc)))
; cell:global-set! : cell:global any -> void
; sets the value of the global cell
(define (cell:global-set! gc nv)
(frame-set! (search-stack global-root?)
(cell-id gc)
nv))
; cell:session-ref : cell:session -> any
; returns the value of the session cell
(define (cell:session-ref sc)
(frame-ref (search-stack session-root?)
(cell-id sc)))
; cell:session-set! : cell:session any -> void
; sets the value of the session cell
(define (cell:session-set! sc nv)
(frame-set! (search-stack session-root?)
(cell-id sc)
nv))
; cell:local-ref : cell:local -> any
; returns the value of the local cell
(define (cell:local-ref lc)
(frame-ref (search-stack frame?)
(cell-id lc)))
; cell:local-set! : cell:local any -> void
; sets the value of the local cell at the last place it was set, including the default
(define (cell:local-set! lc nv)
(frame-set! (search-stack
(lambda (f) (frame-set? f (cell-id lc))))
(cell-id lc)
nv))
; cell:local-mask : cell:local any -> void
; masks the local cell to the given value
(define (cell:local-mask lc nv)
(frame-set! (search-stack frame?)
(cell-id lc)
nv))
; cell-ref : cell -> any
(define (cell-ref c)
(cond
[(cell:global? c) (cell:global-ref c)]
[(cell:session? c) (cell:session-ref c)]
[(cell:local? c) (cell:local-ref c)]))
; ;; linking parameters to cells
; (define *parameter-links* (ext:make-cell:session (list)))
; (define-struct parameter-link (parameter cell))
;
; ; link-parameter : parameter cell -> void
; (define (link-parameter p c)
; (cell:session-set! *parameter-links*
; (cons (make-parameter-link p c)
; (cell:session-ref *parameter-links*))))
;
; ; reinstall-linked-parameters : -> void
; (define (reinstall-linked-parameters)
; (for-each (lambda (link)
; ((parameter-link-parameter link)
; (cell-ref (parameter-link-cell link))))
; (cell:session-ref *parameter-links*)))
(provide with-frame
with-frame-after
(rename ext:make-cell:global make-web-cell:global)
(rename cell:global-ref web-cell:global-ref)
(rename cell:global-set! web-cell:global-set!)
(rename ext:make-cell:session make-web-cell:session)
(rename cell:session-ref web-cell:session-ref)
(rename cell:session-set! web-cell:session-set!)
(rename ext:make-cell:local make-web-cell:local)
(rename cell:local-ref web-cell:local-ref)
(rename cell:local-set! web-cell:local-set!)
(rename cell:local-mask web-cell:local-mask)))