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

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

33
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)]
@ -23,9 +25,17 @@
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)))