allowing different continuation managers
svn: r2930
This commit is contained in:
Jay McCarthy
parent
18c28a5316
commit
34cd19c52e
|
|
@ -44,4 +44,4 @@
|
|||
;; adjust-connection-timeout!: connection number -> void
|
||||
;; change the expiration time for this connection
|
||||
(define (adjust-connection-timeout! conn time)
|
||||
(reset-timer (connection-timer conn) time)))
|
||||
(reset-timer! (connection-timer conn) time)))
|
||||
|
|
@ -1,16 +1,19 @@
|
|||
(module dispatch-servlets mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "plt-match.ss")
|
||||
(lib "class.ss")
|
||||
(lib "unitsig.ss"))
|
||||
(require "dispatch.ss"
|
||||
"web-server-structs.ss"
|
||||
"connection-manager.ss"
|
||||
"response.ss"
|
||||
"servlet-tables.ss"
|
||||
"servlet.ss"
|
||||
"sig.ss"
|
||||
"timer.ss"
|
||||
"util.ss"
|
||||
"managers/manager.ss"
|
||||
"managers/timeouts.ss"
|
||||
"private/url.ss"
|
||||
"private/servlet.ss"
|
||||
"private/cache-table.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
|
@ -27,24 +30,27 @@
|
|||
|
||||
;; servlet-content-producer: connection request -> void
|
||||
(define (servlet-content-producer conn req)
|
||||
(let ([meth (request-method req)])
|
||||
(if (eq? meth 'head)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
||||
'() (list "ignored"))
|
||||
meth)
|
||||
(let ([uri (request-uri req)])
|
||||
(set-request-bindings/raw!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)))
|
||||
(cond
|
||||
[(continuation-url? uri)
|
||||
=> (lambda (k-ref)
|
||||
(invoke-servlet-continuation conn req k-ref))]
|
||||
[else
|
||||
(servlet-content-producer/path conn req uri)])))))
|
||||
(define meth (request-method req))
|
||||
(define uri (request-uri req))
|
||||
(case meth
|
||||
[(head)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
||||
'() (list "ignored"))
|
||||
meth)]
|
||||
[else
|
||||
(set-request-bindings/raw!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)))
|
||||
(cond
|
||||
[(continuation-url? uri)
|
||||
=> (match-lambda
|
||||
[(list instance-id k-id salt)
|
||||
(invoke-servlet-continuation conn req instance-id k-id salt)])]
|
||||
[else
|
||||
(servlet-content-producer/path conn req uri)])]))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
|
|
@ -66,74 +72,71 @@
|
|||
[(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(let/cc suspend
|
||||
; Create the session frame
|
||||
(with-frame
|
||||
(let* ([servlet-custodian (make-servlet-custodian)]
|
||||
[inst (create-new-instance!
|
||||
config:instances servlet-custodian
|
||||
(make-execution-context
|
||||
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
|
||||
(exn-message e)
|
||||
(exn-continuation-marks e))))])
|
||||
(url-path->path
|
||||
servlet-root
|
||||
(url-path->string (url-path uri))))]
|
||||
[servlet-exit-handler (make-servlet-exit-handler inst)])
|
||||
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
|
||||
[current-custodian servlet-custodian]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(let (;; timer thread must be within the dynamic extent of
|
||||
;; servlet custodian
|
||||
[time-bomb (start-timer timeouts-default-servlet
|
||||
(lambda ()
|
||||
(servlet-exit-handler #f)))]
|
||||
;; any resources (e.g. threads) created when the
|
||||
;; servlet is loaded should be within the dynamic
|
||||
;; extent of the servlet custodian
|
||||
[the-servlet (cached-load real-servlet-path)])
|
||||
(parameterize ([current-namespace (servlet-namespace the-servlet)]
|
||||
[current-servlet-continuation-expiration-handler
|
||||
(servlet-instance-expiration-handler the-servlet)])
|
||||
(set-servlet-instance-timer! inst time-bomb)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(make-servlet-exception-handler inst)])
|
||||
;; Two possibilities:
|
||||
;; - module servlet. start : Request -> Void handles
|
||||
;; output-response via send/finish, etc.
|
||||
;; - unit/sig or simple xexpr servlet. These must produce a
|
||||
;; response, which is then output by the server.
|
||||
;; Here, we do not know if the servlet was a module,
|
||||
;; unit/sig, or Xexpr; we do know whether it produces a
|
||||
;; response.
|
||||
(let ([r ((servlet-handler the-servlet) req)])
|
||||
(when (response? r)
|
||||
(send/back r))))))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post sema))))
|
||||
(define servlet-mutex (make-semaphore 0))
|
||||
(define last-servlet (thread-cell-ref current-servlet))
|
||||
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id))
|
||||
(let/cc suspend
|
||||
; Create the session frame
|
||||
(with-frame
|
||||
(define instance-custodian (make-servlet-custodian))
|
||||
(define servlet-path
|
||||
(with-handlers
|
||||
([void (lambda (e)
|
||||
(raise (make-exn:fail:filesystem:exists:servlet
|
||||
(exn-message e)
|
||||
(exn-continuation-marks e))))])
|
||||
(url-path->path
|
||||
servlet-root
|
||||
(url-path->string (url-path uri)))))
|
||||
(parameterize ([current-directory (get-servlet-base-dir servlet-path)]
|
||||
[current-custodian instance-custodian]
|
||||
[exit-handler
|
||||
(lambda _
|
||||
(kill-connection! conn)
|
||||
(custodian-shutdown-all instance-custodian))])
|
||||
;; any resources (e.g. threads) created when the
|
||||
;; servlet is loaded should be within the dynamic
|
||||
;; extent of the servlet custodian
|
||||
(define the-servlet (cached-load servlet-path))
|
||||
(thread-cell-set! current-servlet the-servlet)
|
||||
(parameterize ([current-namespace (servlet-namespace the-servlet)])
|
||||
(define manager (servlet-manager the-servlet))
|
||||
(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)
|
||||
(make-servlet-exception-handler data)])
|
||||
;; Two possibilities:
|
||||
;; - module servlet. start : Request -> Void handles
|
||||
;; output-response via send/finish, etc.
|
||||
;; - unit/sig or simple xexpr servlet. These must produce a
|
||||
;; response, which is then output by the server.
|
||||
;; Here, we do not know if the servlet was a module,
|
||||
;; unit/sig, or Xexpr; we do know whether it produces a
|
||||
;; response.
|
||||
(define r ((servlet-handler the-servlet) req))
|
||||
(when (response? r)
|
||||
(send/back r))))))))
|
||||
(thread-cell-set! current-servlet last-servlet)
|
||||
(thread-cell-set! current-servlet-instance-id last-servlet-instance-id)
|
||||
(semaphore-post servlet-mutex)))
|
||||
|
||||
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
|
||||
;; exit handler for a servlet
|
||||
(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
|
||||
(request-uri req))))
|
||||
;; default-server-instance-expiration-handler : (request -> response)
|
||||
(define (default-servlet-instance-expiration-handler req)
|
||||
(responders-file-not-found
|
||||
(request-uri req)))
|
||||
|
||||
;; make-servlet-exception-handler: servlet-instance -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
|
|
@ -148,101 +151,81 @@
|
|||
;; * 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)
|
||||
(lambda (the-exn)
|
||||
(let* ([ctxt (servlet-instance-context inst)]
|
||||
[req (execution-context-request ctxt)]
|
||||
[resp (responders-servlet
|
||||
(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)))))
|
||||
(define ((make-servlet-exception-handler inst-data) the-exn)
|
||||
(define context (servlet-instance-data-context inst-data))
|
||||
(define request (execution-context-request context))
|
||||
(define resp
|
||||
(responders-servlet
|
||||
(request-uri request)
|
||||
the-exn))
|
||||
;; Don't handle twice
|
||||
(with-handlers ([exn:fail? (lambda (exn) (void))])
|
||||
(output-response/method
|
||||
(execution-context-connection context)
|
||||
resp (request-method request)))
|
||||
((execution-context-suspend context)))
|
||||
|
||||
;; path -> path
|
||||
;; The actual servlet's parent directory.
|
||||
(define (get-servlet-base-dir servlet-path)
|
||||
(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))))))
|
||||
(let loop ([path servlet-path])
|
||||
(define-values (base name must-be-dir?) (split-path path))
|
||||
(or (if must-be-dir?
|
||||
(and (directory-exists? path) path)
|
||||
(and (directory-exists? base) base))
|
||||
(loop base))))
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req k-ref)
|
||||
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
|
||||
(let* ([uri (request-uri req)]
|
||||
[real-servlet-path (url-path->path
|
||||
servlet-root
|
||||
(url-path->string (url-path uri)))]
|
||||
[the-servlet (cached-load real-servlet-path)])
|
||||
(parameterize ([current-custodian (servlet-custodian the-servlet)])
|
||||
(let ([default-servlet-instance-expiration-handler
|
||||
(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)
|
||||
(output-response/method
|
||||
conn
|
||||
((servlet-instance-expiration-handler the-servlet) req)
|
||||
(request-method req)))]
|
||||
[exn:servlet: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)
|
||||
(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)
|
||||
(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))))))
|
||||
(define (invoke-servlet-continuation conn req instance-id k-id salt)
|
||||
(define uri (request-uri req))
|
||||
(define servlet-path
|
||||
(url-path->path
|
||||
servlet-root
|
||||
(url-path->string (url-path uri))))
|
||||
(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)])
|
||||
(with-handlers ([exn:fail:servlet-manager:no-instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn)
|
||||
req)
|
||||
(request-method req)))]
|
||||
[exn:fail:servlet-manager:no-continuation?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((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)))])
|
||||
(define data (send manager instance-lookup-data instance-id))
|
||||
; 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-data-mutex data))
|
||||
(let/cc suspend
|
||||
(define k (send manager continuation-lookup instance-id k-id salt))
|
||||
(set-servlet-instance-data-context!
|
||||
data
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(k req))
|
||||
(semaphore-post (servlet-instance-data-mutex data))))
|
||||
(thread-cell-set! current-servlet-instance-id last-servlet-instance-id)
|
||||
(thread-cell-set! current-servlet last-servlet))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
|
|
@ -252,12 +235,12 @@
|
|||
;; timestamps are no longer checked for performance. The cache must be explicitly
|
||||
;; refreshed (see dispatch).
|
||||
(define (cached-load servlet-path)
|
||||
(let ([entry-id (string->symbol (path->string servlet-path))])
|
||||
(cache-table-lookup!
|
||||
(unbox config:scripts)
|
||||
entry-id
|
||||
(lambda ()
|
||||
(reload-servlet-script servlet-path)))))
|
||||
(define entry-id (string->symbol (path->string servlet-path)))
|
||||
(cache-table-lookup!
|
||||
(unbox config:scripts)
|
||||
entry-id
|
||||
(lambda ()
|
||||
(reload-servlet-script servlet-path))))
|
||||
|
||||
;; exn:i/o:filesystem:servlet-not-found =
|
||||
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
|
||||
|
|
@ -297,77 +280,88 @@
|
|||
(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)
|
||||
; XXX load/use-compiled breaks errortrace
|
||||
(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
|
||||
(make-default-servlet-instance-expiration-handler))]
|
||||
; 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
|
||||
(make-default-servlet-instance-expiration-handler)))]
|
||||
[(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
|
||||
(make-default-servlet-instance-expiration-handler))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))))))
|
||||
(parameterize ([current-namespace (config:make-servlet-namespace)]
|
||||
[current-custodian (make-servlet-custodian)])
|
||||
; XXX load/use-compiled breaks errortrace
|
||||
(define 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 (current-custodian)
|
||||
(current-namespace)
|
||||
(make-object timeout-manager%
|
||||
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)
|
||||
;; 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 (current-custodian)
|
||||
(current-namespace)
|
||||
(make-object timeout-manager%
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
(v1.module->v1.lambda timeout start)))]
|
||||
[(v2-transitional) ; XXX: Undocumented
|
||||
(let ([start (dynamic-require module-name 'start)]
|
||||
[manager (with-handlers
|
||||
([exn:fail:contract?
|
||||
(lambda (exn)
|
||||
(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)
|
||||
manager
|
||||
start))]
|
||||
[else
|
||||
(error 'load-servlet/path "unknown servlet version ~e" version)]))]
|
||||
;; response
|
||||
[(response? s)
|
||||
(make-servlet (current-custodian)
|
||||
(current-namespace)
|
||||
(make-object timeout-manager%
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
(v0.response->v1.lambda s a-path))]
|
||||
[else
|
||||
(error '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))))
|
||||
(define svt-bin-re (regexp "^/servlets(;.*\\*.*\\*.*)?/.*"))
|
||||
(define (servlet-bin? 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)
|
||||
method)]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
timeouts-servlet-connection)
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req)]
|
||||
[else
|
||||
(next-dispatcher)])))))
|
||||
(define-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)
|
||||
method)]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
timeouts-servlet-connection)
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req)]
|
||||
[else
|
||||
(next-dispatcher)]))))
|
||||
15
collects/web-server/managers/manager.ss
Normal file
15
collects/web-server/managers/manager.ss
Normal 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
113
collects/web-server/managers/timeouts.ss
Normal 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
31
collects/web-server/private/servlet.ss
Normal 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)))
|
||||
|
|
@ -7,8 +7,8 @@
|
|||
(provide
|
||||
match-url-params)
|
||||
(provide/contract
|
||||
[continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))]
|
||||
[embed-ids ((list/c symbol? number? number?) url? . -> . string?)])
|
||||
[continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))]
|
||||
[embed-ids ((list/c number? number? number?) url? . -> . string?)])
|
||||
|
||||
;; ********************************************************************************
|
||||
;; Parameter Embedding
|
||||
|
|
@ -35,11 +35,13 @@
|
|||
#f
|
||||
(match (match-url-params (first k-params))
|
||||
[(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)])
|
||||
(if (and (number? k-id/n)
|
||||
(if (and (number? instance/n)
|
||||
(number? k-id/n)
|
||||
(number? salt/n))
|
||||
(list (string->symbol instance)
|
||||
(list instance/n
|
||||
k-id/n
|
||||
salt/n)
|
||||
; XXX: Maybe log this in some way?
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
(module servlet-env mzscheme
|
||||
(require (lib "sendurl.ss" "net")
|
||||
(lib "class.ss")
|
||||
(lib "unitsig.ss"))
|
||||
(require "configuration.ss"
|
||||
"web-server.ss"
|
||||
"sig.ss"
|
||||
"servlet-tables.ss"
|
||||
"util.ss"
|
||||
"response.ss"
|
||||
"managers/timeouts.ss"
|
||||
"private/servlet.ss"
|
||||
"private/cache-table.ss")
|
||||
(require "servlet.ss")
|
||||
(provide (rename on-web:syntax on-web)
|
||||
|
|
@ -61,13 +63,14 @@
|
|||
"default-web-root" "."
|
||||
the-path)))
|
||||
(lambda ()
|
||||
(make-servlet the-servlet
|
||||
(make-custodian)
|
||||
(make-servlet (make-custodian)
|
||||
(i:make-servlet-namespace)
|
||||
30
|
||||
(lambda (request)
|
||||
(make-object timeout-manager%
|
||||
(lambda (request)
|
||||
`(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^
|
||||
(import)
|
||||
(define port the-port)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
(module servlet mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "class.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "xml.ss" "xml"))
|
||||
(require "servlet-tables.ss"
|
||||
"response.ss"
|
||||
(require "response.ss"
|
||||
"private/servlet.ss"
|
||||
"private/url.ss"
|
||||
"servlet-helpers.ss"
|
||||
"timer.ss"
|
||||
|
|
@ -11,7 +12,7 @@
|
|||
|
||||
;; CONTRACT HELPERS
|
||||
(define servlet-response? any/c)
|
||||
|
||||
|
||||
(define (xexpr/callback? x)
|
||||
(correct-xexpr? x
|
||||
(lambda () #t)
|
||||
|
|
@ -20,7 +21,7 @@
|
|||
#t
|
||||
(begin ((error-display-handler) (exn-message exn) exn)
|
||||
#f)))))
|
||||
|
||||
|
||||
(define response-generator?
|
||||
(string? . -> . servlet-response?))
|
||||
|
||||
|
|
@ -38,7 +39,7 @@
|
|||
|
||||
;; ************************************************************
|
||||
;; HELPERS
|
||||
|
||||
|
||||
;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr?
|
||||
;; Change procedures to the send/suspend of a k-url
|
||||
(define (xexpr/callback->xexpr p->a p-exp)
|
||||
|
|
@ -46,14 +47,7 @@
|
|||
[(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e))
|
||||
p-exp)]
|
||||
[(procedure? p-exp) (p->a 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))
|
||||
[else p-exp]))
|
||||
|
||||
;; 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.
|
||||
|
|
@ -93,19 +87,18 @@
|
|||
;; adjust-timeout! : sec -> void
|
||||
;; adjust the timeout on the servlet
|
||||
(define (adjust-timeout! secs)
|
||||
(reset-timer (servlet-instance-timer (get-current-servlet-instance))
|
||||
secs))
|
||||
(send (current-servlet-manager) adjust-timeout! (get-current-servlet-instance-id) secs))
|
||||
|
||||
;; ext:clear-continuations! -> void
|
||||
(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 a response and don't clear the continuation table
|
||||
(define (send/back resp)
|
||||
(let ([ctxt (servlet-instance-context (get-current-servlet-instance))])
|
||||
(output-response (execution-context-connection ctxt) resp)
|
||||
((execution-context-suspend ctxt))))
|
||||
(define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
|
||||
(output-response (execution-context-connection ctxt) resp)
|
||||
((execution-context-suspend ctxt)))
|
||||
|
||||
;; send/finish: response -> void
|
||||
;; send a response and clear the continuation table
|
||||
|
|
@ -124,16 +117,16 @@
|
|||
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(with-frame-after
|
||||
(let/cc k
|
||||
(let* ([inst (get-current-servlet-instance)]
|
||||
[ctxt (servlet-instance-context inst)]
|
||||
[k-embedding (store-continuation! k expiration-handler inst)]
|
||||
[k-url (embed-ids
|
||||
k-embedding
|
||||
(request-uri (execution-context-request ctxt)))]
|
||||
[k-url ((current-url-transform) k-url)]
|
||||
[response (response-generator k-url)])
|
||||
(output-response (execution-context-connection ctxt) response)
|
||||
((execution-context-suspend ctxt)))))))
|
||||
(define instance-id (get-current-servlet-instance-id))
|
||||
(define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
|
||||
(define k-embedding (send (current-servlet-manager) continuation-store! instance-id k expiration-handler))
|
||||
(define k-url ((current-url-transform)
|
||||
(embed-ids
|
||||
(list* instance-id k-embedding)
|
||||
(request-uri (execution-context-request ctxt)))))
|
||||
(define response (response-generator k-url))
|
||||
(output-response (execution-context-connection ctxt) response)
|
||||
((execution-context-suspend ctxt))))))
|
||||
|
||||
;; send/forward: (url -> response) [(request -> response)] -> request
|
||||
;; clear the continuation table, then behave like send/suspend
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(require (lib "list.ss")
|
||||
(lib "async-channel.ss"))
|
||||
(provide timer?
|
||||
start-timer reset-timer increment-timer
|
||||
start-timer reset-timer! increment-timer!
|
||||
cancel-timer!
|
||||
start-timer-manager)
|
||||
|
||||
|
|
@ -73,12 +73,12 @@
|
|||
|
||||
; reset-timer : timer num -> void
|
||||
; 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)))
|
||||
|
||||
; increment-timer : timer num -> void
|
||||
; increment-timer! : timer num -> void
|
||||
; add secs to the timer, rather than replace
|
||||
(define (increment-timer timer secs)
|
||||
(define (increment-timer! timer secs)
|
||||
(revise-timer! timer
|
||||
(+ (- (timer-expire-seconds timer) (current-inexact-milliseconds))
|
||||
(* 1000 secs))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
(module backend-servlet-testing mzscheme
|
||||
(require (lib "connection-manager.ss" "web-server")
|
||||
(lib "servlet-tables.ss" "web-server")
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
"backend.ss"
|
||||
(lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "match.ss")
|
||||
)
|
||||
(lib "private/url.ss" "web-server"))
|
||||
|
||||
(provide run-servlet simple-start-servlet simple-resume-servlet)
|
||||
|
||||
|
|
@ -92,6 +91,4 @@
|
|||
;; Produce a new request, with an url
|
||||
(define (new-request/url new-url)
|
||||
(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")))
|
||||
|
|
@ -1,9 +1,7 @@
|
|||
(module backend mzscheme
|
||||
(require (lib "servlet.ss" "web-server")
|
||||
(lib "servlet-tables.ss" "web-server")
|
||||
(lib "timer.ss" "web-server")
|
||||
(lib "response.ss" "web-server")
|
||||
(all-except (lib "request-parsing.ss" "web-server") request-bindings)
|
||||
(lib "connection-manager.ss" "web-server"))
|
||||
|
||||
(provide start-servlet resume-servlet)
|
||||
|
|
@ -33,7 +31,7 @@
|
|||
(with-handlers ([(lambda (x) #t)
|
||||
(make-servlet-exception-handler inst)])
|
||||
(let ([r (svt (lambda (secs)
|
||||
(reset-timer time-bomb secs))
|
||||
(reset-timer! time-bomb secs))
|
||||
req)])
|
||||
(when (response? r)
|
||||
(send/back r)))))))
|
||||
|
|
@ -70,7 +68,7 @@
|
|||
(let* ([inst (hash-table-get instance-table (car k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-instance
|
||||
(make-exn:servlet:instance
|
||||
"" (current-continuation-marks)))))]
|
||||
[k-table
|
||||
(servlet-instance-k-table inst)])
|
||||
|
|
@ -83,9 +81,7 @@
|
|||
((hash-table-get k-table (cadr k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
(make-exn:servlet:continuation
|
||||
"" (current-continuation-marks)))))
|
||||
req))
|
||||
(semaphore-post (servlet-instance-mutex inst))))
|
||||
)
|
||||
|
||||
(semaphore-post (servlet-instance-mutex inst)))))
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
;; 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
|
||||
;; thread should be used at a time.
|
||||
|
||||
;;
|
||||
;; 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
|
||||
;; cloning Web pages.
|
||||
|
|
@ -17,10 +17,7 @@
|
|||
(lib "servlet.ss" "web-server")
|
||||
(lib "servlet-tables.ss" "web-server")
|
||||
(lib "connection-manager.ss" "web-server")
|
||||
(lib "timer.ss" "web-server")
|
||||
(all-except (lib "request-parsing.ss" "web-server")
|
||||
request-bindings)
|
||||
)
|
||||
(lib "timer.ss" "web-server"))
|
||||
|
||||
(provide start-servlet resume-servlet resume-servlet/headers)
|
||||
|
||||
|
|
@ -134,6 +131,4 @@
|
|||
;; Produce a new request, with bindings
|
||||
(define (new-request/bindings bs)
|
||||
(make-request 'get (string->url "http://www.example.com/") '() bs
|
||||
"a-host-ip" "a-client-ip"))
|
||||
|
||||
)
|
||||
"a-host-ip" "a-client-ip")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user