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

allowing different continuation managers

Browse Source 
svn: r2930
This commit is contained in:
Jay McCarthy 2006-05-13 06:05:04 +00:00
parent 18c28a5316
commit 34cd19c52e
13 changed files with 456 additions and 428 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/connection-manager.ss
View File

@ -44,4 +44,4 @@
;; adjust-connection-timeout!: connection number -> void ;; adjust-connection-timeout!: connection number -> void
;; change the expiration time for this connection ;; change the expiration time for this connection
(define (adjust-connection-timeout! conn time) (define (adjust-connection-timeout! conn time)
(reset-timer (connection-timer conn) time))) (reset-timer! (connection-timer conn) time)))

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

@ -1,16 +1,19 @@
(module dispatch-servlets mzscheme (module dispatch-servlets mzscheme
(require (lib "url.ss" "net") (require (lib "url.ss" "net")
(lib "plt-match.ss")
(lib "class.ss")
(lib "unitsig.ss")) (lib "unitsig.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"web-server-structs.ss" "web-server-structs.ss"
"connection-manager.ss" "connection-manager.ss"
"response.ss" "response.ss"
"servlet-tables.ss"
"servlet.ss" "servlet.ss"
"sig.ss" "sig.ss"
"timer.ss"
"util.ss" "util.ss"
"managers/manager.ss"
"managers/timeouts.ss"
"private/url.ss" "private/url.ss"
"private/servlet.ss"
"private/cache-table.ss") "private/cache-table.ss")
(provide interface-version (provide interface-version
gen-dispatcher) gen-dispatcher)
@ -27,24 +30,27 @@
;; servlet-content-producer: connection request -> void ;; servlet-content-producer: connection request -> void
(define (servlet-content-producer conn req) (define (servlet-content-producer conn req)
(let ([meth (request-method req)]) (define meth (request-method req))
(if (eq? meth 'head) (define uri (request-uri req))
(case 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)]) [else
(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)))
(cond (cond
[(continuation-url? uri) [(continuation-url? uri)
=> (lambda (k-ref) => (match-lambda
(invoke-servlet-continuation conn req k-ref))] [(list instance-id k-id salt)
(invoke-servlet-continuation conn req instance-id k-id salt)])]
[else [else
(servlet-content-producer/path conn req uri)]))))) (servlet-content-producer/path conn req uri)])]))
;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string))
;; read the bindings and handle any exceptions ;; read the bindings and handle any exceptions
@ -66,45 +72,52 @@
[(lambda (x) #t) [(lambda (x) #t)
(lambda (the-exn) (lambda (the-exn)
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
(let ([sema (make-semaphore 0)] (define servlet-mutex (make-semaphore 0))
[last-inst (thread-cell-ref current-servlet-instance)]) (define last-servlet (thread-cell-ref current-servlet))
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id))
(let/cc suspend (let/cc suspend
; Create the session frame ; Create the session frame
(with-frame (with-frame
(let* ([servlet-custodian (make-servlet-custodian)] (define instance-custodian (make-servlet-custodian))
[inst (create-new-instance! (define servlet-path
config:instances servlet-custodian (with-handlers
(make-execution-context ([void (lambda (e)
conn req (lambda () (suspend #t)))
sema
(start-timer 0 void))]
[real-servlet-path (with-handlers ([void (lambda (e)
(raise (make-exn:fail:filesystem:exists:servlet (raise (make-exn:fail:filesystem:exists:servlet
(exn-message e) (exn-message e)
(exn-continuation-marks e))))]) (exn-continuation-marks e))))])
(url-path->path (url-path->path
servlet-root servlet-root
(url-path->string (url-path uri))))] (url-path->string (url-path uri)))))
[servlet-exit-handler (make-servlet-exit-handler inst)]) (parameterize ([current-directory (get-servlet-base-dir servlet-path)]
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] [current-custodian instance-custodian]
[current-custodian servlet-custodian] [exit-handler
[exit-handler servlet-exit-handler]) (lambda _
(thread-cell-set! current-servlet-instance inst) (kill-connection! conn)
(let (;; timer thread must be within the dynamic extent of (custodian-shutdown-all instance-custodian))])
;; servlet custodian
[time-bomb (start-timer timeouts-default-servlet
(lambda ()
(servlet-exit-handler #f)))]
;; any resources (e.g. threads) created when the ;; any resources (e.g. threads) created when the
;; servlet is loaded should be within the dynamic ;; servlet is loaded should be within the dynamic
;; extent of the servlet custodian ;; extent of the servlet custodian
[the-servlet (cached-load real-servlet-path)]) (define the-servlet (cached-load servlet-path))
(parameterize ([current-namespace (servlet-namespace the-servlet)] (thread-cell-set! current-servlet the-servlet)
[current-servlet-continuation-expiration-handler (parameterize ([current-namespace (servlet-namespace the-servlet)])
(servlet-instance-expiration-handler the-servlet)]) (define manager (servlet-manager the-servlet))
(set-servlet-instance-timer! inst time-bomb) (define data
(make-servlet-instance-data
servlet-mutex
(make-execution-context
conn req (lambda () (suspend #t)))))
(define the-exit-handler
(lambda _
(kill-connection!
(execution-context-connection
(servlet-instance-data-context
data)))
(custodian-shutdown-all instance-custodian)))
(parameterize ([exit-handler the-exit-handler])
(define instance-id (send manager create-instance data the-exit-handler))
(thread-cell-set! current-servlet-instance-id instance-id)
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst)]) (make-servlet-exception-handler data)])
;; Two possibilities: ;; Two possibilities:
;; - module servlet. start : Request -> Void handles ;; - module servlet. start : Request -> Void handles
;; output-response via send/finish, etc. ;; output-response via send/finish, etc.
@ -113,27 +126,17 @@
;; Here, we do not know if the servlet was a module, ;; Here, we do not know if the servlet was a module,
;; unit/sig, or Xexpr; we do know whether it produces a ;; unit/sig, or Xexpr; we do know whether it produces a
;; response. ;; response.
(let ([r ((servlet-handler the-servlet) req)]) (define r ((servlet-handler the-servlet) req))
(when (response? r) (when (response? r)
(send/back r)))))))))) (send/back r))))))))
(thread-cell-set! current-servlet-instance last-inst) (thread-cell-set! current-servlet last-servlet)
(semaphore-post sema)))) (thread-cell-set! current-servlet-instance-id last-servlet-instance-id)
(semaphore-post servlet-mutex)))
;; make-servlet-exit-handler: servlet-instance -> alpha -> void ;; default-server-instance-expiration-handler : (request -> response)
;; exit handler for a servlet (define (default-servlet-instance-expiration-handler req)
(define (make-servlet-exit-handler inst)
(lambda (x)
(remove-instance! config:instances inst)
(kill-connection!
(execution-context-connection
(servlet-instance-context inst)))
(custodian-shutdown-all (servlet-instance-custodian inst))))
;; make-default-server-instance-expiration-handler : -> (request -> response)
(define (make-default-servlet-instance-expiration-handler)
(lambda (req)
(responders-file-not-found (responders-file-not-found
(request-uri req)))) (request-uri req)))
;; make-servlet-exception-handler: servlet-instance -> exn -> void ;; make-servlet-exception-handler: servlet-instance -> exn -> void
;; This exception handler traps all unhandled servlet exceptions ;; This exception handler traps all unhandled servlet exceptions
@ -148,101 +151,81 @@
;; * Also, suspend will post to the semaphore so that future ;; * Also, suspend will post to the semaphore so that future
;; requests won't be blocked. ;; requests won't be blocked.
;; * This fixes PR# 7066 ;; * This fixes PR# 7066
(define (make-servlet-exception-handler inst) (define ((make-servlet-exception-handler inst-data) the-exn)
(lambda (the-exn) (define context (servlet-instance-data-context inst-data))
(let* ([ctxt (servlet-instance-context inst)] (define request (execution-context-request context))
[req (execution-context-request ctxt)] (define resp
[resp (responders-servlet (responders-servlet
(request-uri req) (request-uri request)
the-exn)]) the-exn))
;; Don't handle twice ;; Don't handle twice
(with-handlers ([exn:fail? (lambda (exn) (void))]) (with-handlers ([exn:fail? (lambda (exn) (void))])
(output-response/method (output-response/method
(execution-context-connection ctxt) (execution-context-connection context)
resp (request-method req))) resp (request-method request)))
((execution-context-suspend ctxt))))) ((execution-context-suspend context)))
;; path -> path ;; path -> path
;; The actual servlet's parent directory. ;; The actual servlet's parent directory.
(define (get-servlet-base-dir servlet-path) (define (get-servlet-base-dir servlet-path)
(let loop ((path servlet-path)) (let loop ([path servlet-path])
(let-values ([(base name must-be-dir?) (split-path path)]) (define-values (base name must-be-dir?) (split-path path))
(if must-be-dir? (or (if must-be-dir?
(or (and (directory-exists? path) path) (and (directory-exists? path) path)
(loop base)) (and (directory-exists? base) base))
(or (and (directory-exists? base) base) (loop base))))
(loop base))))))
;; invoke-servlet-continuation: connection request continuation-reference -> void ;; invoke-servlet-continuation: connection request continuation-reference -> void
;; pull the continuation out of the table and apply it ;; pull the continuation out of the table and apply it
(define (invoke-servlet-continuation conn req k-ref) (define (invoke-servlet-continuation conn req instance-id k-id salt)
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) (define uri (request-uri req))
(let* ([uri (request-uri req)] (define servlet-path
[real-servlet-path (url-path->path (url-path->path
servlet-root servlet-root
(url-path->string (url-path uri)))] (url-path->string (url-path uri))))
[the-servlet (cached-load real-servlet-path)]) (define last-servlet (thread-cell-ref current-servlet))
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id))
(define the-servlet (cached-load servlet-path))
(define manager (servlet-manager the-servlet))
(thread-cell-set! current-servlet the-servlet)
(thread-cell-set! current-servlet-instance-id instance-id)
(parameterize ([current-custodian (servlet-custodian the-servlet)]) (parameterize ([current-custodian (servlet-custodian the-servlet)])
(let ([default-servlet-instance-expiration-handler (with-handlers ([exn:fail:servlet-manager:no-instance?
(make-default-servlet-instance-expiration-handler)]
[last-inst (thread-cell-ref current-servlet-instance)])
(thread-cell-set! current-servlet-instance #f)
(with-handlers ([exn:servlet:instance?
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((servlet-instance-expiration-handler the-servlet) req) ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn)
req)
(request-method req)))] (request-method req)))]
[exn:servlet:continuation? [exn:fail:servlet-manager:no-continuation?
(lambda (the-exn)
(let ([handler (exn:servlet:continuation-expiration-handler the-exn)])
(if (eq? handler (servlet-instance-expiration-handler the-servlet))
(output-response/method
conn (handler req) (request-method req))
(handler req))))]
[exn:servlet:no-current-instance?
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((default-servlet-instance-expiration-handler) req) ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn)
req)
(request-method req)))]
[exn:fail:servlet:instance?
(lambda (the-exn)
(output-response/method
conn
(default-servlet-instance-expiration-handler
req)
(request-method req)))]) (request-method req)))])
(let* ([inst (define data (send manager instance-lookup-data instance-id))
(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 ; We don't use call-with-semaphore or dynamic-wind because we
; always call a continuation. The exit-handler above ensures that ; always call a continuation. The exit-handler above ensures that
; the post is done. ; the post is done.
(semaphore-wait (servlet-instance-mutex inst)) (semaphore-wait (servlet-instance-data-mutex data))
(thread-cell-set! current-servlet-instance inst) (let/cc suspend
(set-servlet-instance-context! (define k (send manager continuation-lookup instance-id k-id salt))
inst (set-servlet-instance-data-context!
data
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t)))) conn req (lambda () (suspend #t))))
(increment-timer (servlet-instance-timer inst) (k req))
(servlet-connection-interval-timeout the-servlet)) (semaphore-post (servlet-instance-data-mutex data))))
(let-values ([(k k-expiration-handler k-salt) (thread-cell-set! current-servlet-instance-id last-servlet-instance-id)
(apply values (thread-cell-set! current-servlet last-servlet))
(hash-table-get
k-table uk-id
(lambda ()
(raise
(make-exn:servlet:continuation
"" (current-continuation-marks)
(servlet-instance-expiration-handler the-servlet))))))])
(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))))))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
@ -252,12 +235,12 @@
;; timestamps are no longer checked for performance. The cache must be explicitly ;; timestamps are no longer checked for performance. The cache must be explicitly
;; refreshed (see dispatch). ;; refreshed (see dispatch).
(define (cached-load servlet-path) (define (cached-load servlet-path)
(let ([entry-id (string->symbol (path->string servlet-path))]) (define entry-id (string->symbol (path->string servlet-path)))
(cache-table-lookup! (cache-table-lookup!
(unbox config:scripts) (unbox config:scripts)
entry-id entry-id
(lambda () (lambda ()
(reload-servlet-script servlet-path))))) (reload-servlet-script servlet-path))))
;; exn:i/o:filesystem:servlet-not-found = ;; exn:i/o:filesystem:servlet-not-found =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
@ -297,21 +280,21 @@
(lambda (initial-request) (lambda (initial-request)
(adjust-timeout! timeout) (adjust-timeout! timeout)
(start initial-request))) (start initial-request)))
(let ([servlet-custodian (make-servlet-custodian)])
(parameterize ([current-namespace (config:make-servlet-namespace)] (parameterize ([current-namespace (config:make-servlet-namespace)]
[current-custodian servlet-custodian]) [current-custodian (make-servlet-custodian)])
(and (file-exists? a-path)
; XXX load/use-compiled breaks errortrace ; XXX load/use-compiled breaks errortrace
(let ([s (load/use-compiled a-path)]) (define s (load/use-compiled a-path))
(cond (cond
;; signed-unit servlet ;; signed-unit servlet
; MF: I'd also like to test that s has the correct import signature. ; MF: I'd also like to test that s has the correct import signature.
[(unit/sig? s) [(unit/sig? s)
(make-servlet (v0.servlet->v1.lambda s) (make-servlet (current-custodian)
servlet-custodian
(current-namespace) (current-namespace)
timeouts-default-servlet (make-object timeout-manager%
(make-default-servlet-instance-expiration-handler))] default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v0.servlet->v1.lambda s))]
; FIX - reason about exceptions from dynamic require (catch and report if not already) ; FIX - reason about exceptions from dynamic require (catch and report if not already)
;; module servlet ;; module servlet
[(void? s) [(void? s)
@ -321,40 +304,51 @@
[(v1) [(v1)
(let ([timeout (dynamic-require module-name 'timeout)] (let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)]) [start (dynamic-require module-name 'start)])
(make-servlet (v1.module->v1.lambda timeout start) (make-servlet (current-custodian)
servlet-custodian
(current-namespace) (current-namespace)
timeouts-default-servlet (make-object timeout-manager%
(make-default-servlet-instance-expiration-handler)))] default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v1.module->v1.lambda timeout start)))]
[(v2-transitional) ; XXX: Undocumented [(v2-transitional) ; XXX: Undocumented
(let ([timeout (dynamic-require module-name 'timeout)] (let ([start (dynamic-require module-name 'start)]
[instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)] [manager (with-handlers
[start (dynamic-require module-name 'start)]) ([exn:fail:contract?
(make-servlet (v1.module->v1.lambda timeout start) (lambda (exn)
servlet-custodian (define timeout (dynamic-require module-name 'timeout))
(define instance-expiration-handler
(dynamic-require module-name 'instance-expiration-handler))
(make-object timeout-manager%
instance-expiration-handler
timeouts-servlet-connection
timeout))])
(dynamic-require module-name 'manager))])
(make-servlet (current-custodian)
(current-namespace) (current-namespace)
timeout manager
instance-expiration-handler))] start))]
[else [else
(raise (format "unknown servlet version ~e" version))]))] (error 'load-servlet/path "unknown servlet version ~e" version)]))]
;; response ;; response
[(response? s) [(response? s)
(make-servlet (v0.response->v1.lambda s a-path) (make-servlet (current-custodian)
servlet-custodian
(current-namespace) (current-namespace)
timeouts-default-servlet (make-object timeout-manager%
(make-default-servlet-instance-expiration-handler))] default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v0.response->v1.lambda s a-path))]
[else [else
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))) (error 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))
(define servlet-bin? (define svt-bin-re (regexp "^/servlets(;.*\\*.*\\*.*)?/.*"))
(let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")]) (define (servlet-bin? str)
(lambda (str) (regexp-match svt-bin-re str))
(regexp-match svt-bin-re str))))
;; return dispatcher ;; return dispatcher
(lambda (conn req) (lambda (conn req)
(let-values ([(uri method path) (decompose-request req)]) (define-values (uri method path) (decompose-request req))
(cond [(string=? "/conf/refresh-servlets" path) (cond [(string=? "/conf/refresh-servlets" path)
;; more here - this is broken - only out of date or specifically mentioned ;; more here - this is broken - only out of date or specifically mentioned
;; scripts should be flushed. This destroys persistent state! ;; scripts should be flushed. This destroys persistent state!
@ -370,4 +364,4 @@
;; more here - make timeouts proportional to size of bindings ;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req)] (servlet-content-producer conn req)]
[else [else
(next-dispatcher)]))))) (next-dispatcher)]))))

15
collects/web-server/managers/manager.ss Normal file
View File

@ -0,0 +1,15 @@
(module manager mzscheme
(require (lib "class.ss"))
(provide (all-defined))
(define manager<%>
(interface ()
create-instance
adjust-timeout!
instance-lookup-data
clear-continuations!
continuation-store!
continuation-lookup))
(define-struct (exn:fail:servlet-manager:no-instance exn:fail) (expiration-handler))
(define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler)))

113
collects/web-server/managers/timeouts.ss Normal file
View File

@ -0,0 +1,113 @@
(module timeouts mzscheme
(require (lib "class.ss")
(lib "plt-match.ss"))
(require "manager.ss")
(require "../timer.ss")
(provide timeout-manager%)
;; Utility
(define (make-counter)
(let ([i 0])
(lambda ()
(set! i (add1 i))
i)))
(define timeout-manager%
(class* object% (manager<%>)
(init-field instance-expiration-handler
instance-timer-length
continuation-timer-length)
(public create-instance
adjust-timeout!
instance-lookup-data
clear-continuations!
continuation-store!
continuation-lookup)
;; Instances
(define instances (make-hash-table))
(define next-instance-id (make-counter))
(define-struct instance (data k-table timer))
(define (create-instance data expire-fn)
(define instance-id (next-instance-id))
(hash-table-put! instances
instance-id
(make-instance data
(create-k-table)
(start-timer instance-timer-length
(lambda ()
(expire-fn)
(hash-table-remove! instances instance-id)))))
instance-id)
(define (adjust-timeout! instance-id secs)
(reset-timer! (instance-timer (instance-lookup instance-id))
secs))
(define (instance-lookup instance-id)
(define instance
(hash-table-get instances instance-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-instance
(format "No instance for id: ~a" instance-id)
(current-continuation-marks)
instance-expiration-handler)))))
(increment-timer! (instance-timer instance)
instance-timer-length)
instance)
;; Continuation table
(define-struct k-table (next-id-fn htable))
(define (create-k-table)
(make-k-table (make-counter) (make-hash-table)))
;; Interface
(define (instance-lookup-data instance-id)
(instance-data (instance-lookup instance-id)))
(define (clear-continuations! instance-id)
(match (instance-lookup instance-id)
[(struct instance (data (and k-table (struct k-table (next-id-fn htable))) instance-timer))
(hash-table-for-each
htable
(match-lambda*
[(list k-id (list salt k expiration-handler k-timer))
(hash-table-put! htable k-id
(list salt #f expiration-handler k-timer))]))]))
(define (continuation-store! instance-id k expiration-handler)
(match (instance-lookup instance-id)
[(struct instance (data (struct k-table (next-id-fn htable)) instance-timer))
(define k-id (next-id-fn))
(define salt (random 100000000))
(hash-table-put! htable
k-id
(list salt k expiration-handler
(start-timer continuation-timer-length
(lambda ()
(hash-table-put! htable k-id
(list salt #f expiration-handler
(start-timer 0 void)))))))
(list k-id salt)]))
(define (continuation-lookup instance-id a-k-id a-salt)
(match (instance-lookup instance-id)
[(struct instance (data (struct k-table (next-id-fn htable)) instance-timer))
(match
(hash-table-get htable a-k-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-continuation
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
instance-expiration-handler))))
[(list salt k expiration-handler k-timer)
(increment-timer! k-timer
continuation-timer-length)
(if (or (not (eq? salt a-salt))
(not k))
(raise (make-exn:fail:servlet-manager:no-continuation
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
expiration-handler))
k)])]))
(super-new))))

31
collects/web-server/private/servlet.ss Normal file
View File

@ -0,0 +1,31 @@
(module servlet mzscheme
(require (lib "class.ss"))
(require "../managers/manager.ss")
(define-struct (exn:fail:servlet:instance exn:fail) ())
(define-struct servlet (custodian namespace manager handler))
(define-struct servlet-instance-data (mutex context))
(define-struct execution-context (connection request suspend))
(define current-servlet (make-thread-cell #f))
(define current-servlet-instance-id (make-thread-cell #f))
(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))))
instance-id)
(define (current-servlet-manager)
(define servlet (thread-cell-ref current-servlet))
(unless servlet
(raise (make-exn:fail:servlet:instance "" (current-continuation-marks))))
(servlet-manager servlet))
(define (current-servlet-instance-data)
(define manager (current-servlet-manager))
(define instance-id (thread-cell-ref current-servlet-instance-id))
(send manager instance-lookup-data instance-id))
(provide (all-defined)))

12
collects/web-server/private/url.ss
View File

@ -7,8 +7,8 @@
(provide (provide
match-url-params) match-url-params)
(provide/contract (provide/contract
[continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))] [continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))]
[embed-ids ((list/c symbol? number? number?) url? . -> . string?)]) [embed-ids ((list/c number? number? number?) url? . -> . string?)])
;; ******************************************************************************** ;; ********************************************************************************
;; Parameter Embedding ;; Parameter Embedding
@ -35,11 +35,13 @@
#f #f
(match (match-url-params (first k-params)) (match (match-url-params (first k-params))
[(list s instance k-id salt) [(list s instance k-id salt)
(let ([k-id/n (string->number k-id)] (let ([instance/n (string->number instance)]
[k-id/n (string->number k-id)]
[salt/n (string->number salt)]) [salt/n (string->number salt)])
(if (and (number? k-id/n) (if (and (number? instance/n)
(number? k-id/n)
(number? salt/n)) (number? salt/n))
(list (string->symbol instance) (list instance/n
k-id/n k-id/n
salt/n) salt/n)
; XXX: Maybe log this in some way? ; XXX: Maybe log this in some way?

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

@ -1,12 +1,14 @@
(module servlet-env mzscheme (module servlet-env mzscheme
(require (lib "sendurl.ss" "net") (require (lib "sendurl.ss" "net")
(lib "class.ss")
(lib "unitsig.ss")) (lib "unitsig.ss"))
(require "configuration.ss" (require "configuration.ss"
"web-server.ss" "web-server.ss"
"sig.ss" "sig.ss"
"servlet-tables.ss"
"util.ss" "util.ss"
"response.ss" "response.ss"
"managers/timeouts.ss"
"private/servlet.ss"
"private/cache-table.ss") "private/cache-table.ss")
(require "servlet.ss") (require "servlet.ss")
(provide (rename on-web:syntax on-web) (provide (rename on-web:syntax on-web)
@ -61,13 +63,14 @@
"default-web-root" "." "default-web-root" "."
the-path))) the-path)))
(lambda () (lambda ()
(make-servlet the-servlet (make-servlet (make-custodian)
(make-custodian)
(i:make-servlet-namespace) (i:make-servlet-namespace)
30 (make-object timeout-manager%
(lambda (request) (lambda (request)
`(html (head "Return to the interaction window.") `(html (head "Return to the interaction window.")
(body (p "Return to the interaction window."))))))) (body (p "Return to the interaction window."))))
30 30)
the-servlet)))
(unit/sig web-config^ (unit/sig web-config^
(import) (import)
(define port the-port) (define port the-port)

111
collects/web-server/servlet-tables.ss
View File

@ -1,111 +0,0 @@
(module servlet-tables mzscheme
(require (lib "contract.ss"))
(require "timer.ss")
(provide (struct exn:servlet:instance ())
(struct exn:servlet:no-current-instance ())
(struct exn:servlet:continuation (expiration-handler))
(struct servlet (handler custodian namespace connection-interval-timeout instance-expiration-handler))
(struct execution-context (connection request suspend))
(struct servlet-instance (id k-table custodian context mutex timer))
current-servlet-instance)
;; current-servlet-instance. The server will parameterize
;; over the current-servlet-instance before invoking a servlet
;; or invoking a continuation. The current-servlet-instance
;; will be in affect for the entire dynamic extent of every
;; continuation associated with that instance.
(define current-servlet-instance (make-thread-cell #f))
(define-struct servlet (handler custodian namespace connection-interval-timeout instance-expiration-handler))
(define-struct servlet-instance (id k-table custodian context mutex timer))
(define-struct execution-context (connection request suspend))
;; Notes:
;; * The servlet-instance-id is the key used for finding the servlet-instance in
;; instance table.
;; * The servlet-instance-k-table stores continuations that were created
;; during this instance.
;; * The servlet-instance-execution-context stores the context in which the
;; instance is executing. The servlet-instance can have only one
;; execution-context at any particular time. The execution-context will be
;; updated whenever a continuation associated with this instance is
;; invoked.
;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the
;; case when it is attempted to invoke multiple continuations
;; simultaneously.
(provide/contract
[store-continuation! (procedure? procedure? servlet-instance? . -> . (list/c symbol? integer? integer?))]
[create-new-instance! (hash-table? custodian? execution-context? semaphore? timer?
. -> . servlet-instance?)]
[remove-instance! (hash-table? servlet-instance? . -> . any)]
[clear-continuations! (servlet-instance? . -> . any)])
;; not found in the instance table
(define-struct (exn:servlet:instance exn) ())
;; not found in the continuatin table
(define-struct (exn:servlet:continuation exn) (expiration-handler))
;; not in dynamic extent of servlet
(define-struct (exn:servlet:no-current-instance exn) ())
(define-values (make-k-table reset-k-table get-k-id!)
(let ([id-slot 'next-k-id])
(values
;; make-k-table: -> (hash-table-of (continuation x expiration handler x salt))
;; Create a continuation table with an initial value for the next
;; continuation id.
(lambda ()
(let ([k-table (make-hash-table)])
(hash-table-put! k-table id-slot 0)
k-table))
;; reset-k-table : hash-table -> (hash-table-of (#f x expiration handler x salt ))
;; Remove the continuations from the k-table
(lambda (k-table0)
(let ([k-table1 (make-hash-table)]
[next-id (hash-table-get k-table0 id-slot)])
(hash-table-for-each
k-table0
(lambda (id v)
(if (eq? id id-slot)
; Save old next-id
(hash-table-put! k-table1 id v)
; Replace continuations with #f
(hash-table-put! k-table1 id (list* #f (cdr v))))))
k-table1))
;; get-k-id!: hash-table -> number
;; get the current-continuation id and increment the internal value
(lambda (k-table)
(let ([id (hash-table-get k-table id-slot)])
(hash-table-put! k-table id-slot (add1 id))
id)))))
;; store-continuation!: continuation expiration-handler servlet-instance -> (list symbol? integer? integer?)
;; store a continuation in a k-table for the provided servlet-instance
(define (store-continuation! k expiration-handler inst)
(let ([k-table (servlet-instance-k-table inst)])
(let ([next-k-id (get-k-id! k-table)]
[salt (random 100000000)])
(hash-table-put! k-table next-k-id (list k expiration-handler salt))
(list (servlet-instance-id inst) next-k-id salt))))
;; clear-continuations!: servlet-instance -> void
;; replace the k-table for the given servlet-instance
(define (clear-continuations! inst)
(set-servlet-instance-k-table!
inst
(reset-k-table
(servlet-instance-k-table inst))))
;; create-new-instance! hash-table custodian execution-context semaphore -> servlet-instance
(define (create-new-instance! instance-table cust ctxt sema timer)
(let* ([inst-id (string->symbol (symbol->string (gensym 'id)))]
[inst
(make-servlet-instance
inst-id (make-k-table) cust ctxt sema timer)])
(hash-table-put! instance-table inst-id inst)
inst))
;; remove-instance!: hash-table servlet-instance -> void
(define (remove-instance! instance-table inst)
(hash-table-remove! instance-table (servlet-instance-id inst))))

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

@ -1,9 +1,10 @@
(module servlet mzscheme (module servlet mzscheme
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "class.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "xml.ss" "xml")) (lib "xml.ss" "xml"))
(require "servlet-tables.ss" (require "response.ss"
"response.ss" "private/servlet.ss"
"private/url.ss" "private/url.ss"
"servlet-helpers.ss" "servlet-helpers.ss"
"timer.ss" "timer.ss"
@ -48,13 +49,6 @@
[(procedure? p-exp) (p->a p-exp)] [(procedure? p-exp) (p->a p-exp)]
[else p-exp])) [else p-exp]))
;; get-current-servlet-instance : -> servlet
(define (get-current-servlet-instance)
(let ([inst (thread-cell-ref current-servlet-instance)])
(unless inst
(raise (make-exn:servlet:no-current-instance "" (current-continuation-marks))))
inst))
;; 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
@ -93,19 +87,18 @@
;; adjust-timeout! : sec -> void ;; adjust-timeout! : sec -> void
;; adjust the timeout on the servlet ;; adjust the timeout on the servlet
(define (adjust-timeout! secs) (define (adjust-timeout! secs)
(reset-timer (servlet-instance-timer (get-current-servlet-instance)) (send (current-servlet-manager) adjust-timeout! (get-current-servlet-instance-id) secs))
secs))
;; ext:clear-continuations! -> void ;; ext:clear-continuations! -> void
(define (clear-continuation-table!) (define (clear-continuation-table!)
(clear-continuations! (get-current-servlet-instance))) (send (current-servlet-manager) clear-continuations! (get-current-servlet-instance-id)))
;; send/back: response -> void ;; send/back: response -> void
;; send a response and don't clear the continuation table ;; send a response and don't clear the continuation table
(define (send/back resp) (define (send/back resp)
(let ([ctxt (servlet-instance-context (get-current-servlet-instance))]) (define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
(output-response (execution-context-connection ctxt) resp) (output-response (execution-context-connection ctxt) resp)
((execution-context-suspend ctxt)))) ((execution-context-suspend ctxt)))
;; send/finish: response -> void ;; send/finish: response -> void
;; send a response and clear the continuation table ;; send a response and clear the continuation table
@ -124,16 +117,16 @@
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(with-frame-after (with-frame-after
(let/cc k (let/cc k
(let* ([inst (get-current-servlet-instance)] (define instance-id (get-current-servlet-instance-id))
[ctxt (servlet-instance-context inst)] (define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
[k-embedding (store-continuation! k expiration-handler inst)] (define k-embedding (send (current-servlet-manager) continuation-store! instance-id k expiration-handler))
[k-url (embed-ids (define k-url ((current-url-transform)
k-embedding (embed-ids
(request-uri (execution-context-request ctxt)))] (list* instance-id k-embedding)
[k-url ((current-url-transform) k-url)] (request-uri (execution-context-request ctxt)))))
[response (response-generator k-url)]) (define response (response-generator k-url))
(output-response (execution-context-connection ctxt) response) (output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt))))))) ((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

8
collects/web-server/timer.ss
View File

@ -3,7 +3,7 @@
(require (lib "list.ss") (require (lib "list.ss")
(lib "async-channel.ss")) (lib "async-channel.ss"))
(provide timer? (provide timer?
start-timer reset-timer increment-timer start-timer reset-timer! increment-timer!
cancel-timer! cancel-timer!
start-timer-manager) start-timer-manager)
@ -73,12 +73,12 @@
; reset-timer : timer num -> void ; reset-timer : timer num -> void
; to cause timer to expire after sec from the adjust-msec-to-live's application ; to cause timer to expire after sec from the adjust-msec-to-live's application
(define (reset-timer timer secs) (define (reset-timer! timer secs)
(revise-timer! timer (* 1000 secs) (timer-action timer))) (revise-timer! timer (* 1000 secs) (timer-action timer)))
; increment-timer : timer num -> void ; increment-timer! : timer num -> void
; add secs to the timer, rather than replace ; add secs to the timer, rather than replace
(define (increment-timer timer secs) (define (increment-timer! timer secs)
(revise-timer! timer (revise-timer! timer
(+ (- (timer-expire-seconds timer) (current-inexact-milliseconds)) (+ (- (timer-expire-seconds timer) (current-inexact-milliseconds))
(* 1000 secs)) (* 1000 secs))

7
collects/web-server/tools/backend-servlet-testing.ss
View File

@ -1,12 +1,11 @@
(module backend-servlet-testing mzscheme (module backend-servlet-testing mzscheme
(require (lib "connection-manager.ss" "web-server") (require (lib "connection-manager.ss" "web-server")
(lib "servlet-tables.ss" "web-server")
(lib "request-parsing.ss" "web-server") (lib "request-parsing.ss" "web-server")
"backend.ss" "backend.ss"
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
(lib "match.ss") (lib "match.ss")
) (lib "private/url.ss" "web-server"))
(provide run-servlet simple-start-servlet simple-resume-servlet) (provide run-servlet simple-start-servlet simple-resume-servlet)
@ -92,6 +91,4 @@
;; Produce a new request, with an url ;; Produce a new request, with an url
(define (new-request/url new-url) (define (new-request/url new-url)
(make-request (make-request
'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip")) 'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip")))
)

12
collects/web-server/tools/backend.ss
View File

@ -1,9 +1,7 @@
(module backend mzscheme (module backend mzscheme
(require (lib "servlet.ss" "web-server") (require (lib "servlet.ss" "web-server")
(lib "servlet-tables.ss" "web-server")
(lib "timer.ss" "web-server") (lib "timer.ss" "web-server")
(lib "response.ss" "web-server") (lib "response.ss" "web-server")
(all-except (lib "request-parsing.ss" "web-server") request-bindings)
(lib "connection-manager.ss" "web-server")) (lib "connection-manager.ss" "web-server"))
(provide start-servlet resume-servlet) (provide start-servlet resume-servlet)
@ -33,7 +31,7 @@
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst)]) (make-servlet-exception-handler inst)])
(let ([r (svt (lambda (secs) (let ([r (svt (lambda (secs)
(reset-timer time-bomb secs)) (reset-timer! time-bomb secs))
req)]) req)])
(when (response? r) (when (response? r)
(send/back r))))))) (send/back r)))))))
@ -70,7 +68,7 @@
(let* ([inst (hash-table-get instance-table (car k-ref) (let* ([inst (hash-table-get instance-table (car k-ref)
(lambda () (lambda ()
(raise (raise
(make-exn:servlet-instance (make-exn:servlet:instance
"" (current-continuation-marks)))))] "" (current-continuation-marks)))))]
[k-table [k-table
(servlet-instance-k-table inst)]) (servlet-instance-k-table inst)])
@ -83,9 +81,7 @@
((hash-table-get k-table (cadr k-ref) ((hash-table-get k-table (cadr k-ref)
(lambda () (lambda ()
(raise (raise
(make-exn:servlet-continuation (make-exn:servlet:continuation
"" (current-continuation-marks))))) "" (current-continuation-marks)))))
req)) req))
(semaphore-post (servlet-instance-mutex inst)))) (semaphore-post (servlet-instance-mutex inst)))))
)

11
collects/web-server/tools/servlet-testing-framework.ss
View File

@ -3,7 +3,7 @@
;; server was written with the assumption that continuations exist across ;; server was written with the assumption that continuations exist across
;; threads; this is not the case in the exp Web server. As a result, only one ;; threads; this is not the case in the exp Web server. As a result, only one
;; thread should be used at a time. ;; thread should be used at a time.
;;
;; Since the real send/* are used, with their full continuation table, one can ;; Since the real send/* are used, with their full continuation table, one can
;; use this to fully pretend to be a Web browser, including back buttons and ;; use this to fully pretend to be a Web browser, including back buttons and
;; cloning Web pages. ;; cloning Web pages.
@ -17,10 +17,7 @@
(lib "servlet.ss" "web-server") (lib "servlet.ss" "web-server")
(lib "servlet-tables.ss" "web-server") (lib "servlet-tables.ss" "web-server")
(lib "connection-manager.ss" "web-server") (lib "connection-manager.ss" "web-server")
(lib "timer.ss" "web-server") (lib "timer.ss" "web-server"))
(all-except (lib "request-parsing.ss" "web-server")
request-bindings)
)
(provide start-servlet resume-servlet resume-servlet/headers) (provide start-servlet resume-servlet resume-servlet/headers)
@ -134,6 +131,4 @@
;; Produce a new request, with bindings ;; Produce a new request, with bindings
(define (new-request/bindings bs) (define (new-request/bindings bs)
(make-request 'get (string->url "http://www.example.com/") '() bs (make-request 'get (string->url "http://www.example.com/") '() bs
"a-host-ip" "a-client-ip")) "a-host-ip" "a-client-ip")))
)