pr7202, servlet-url

svn: r1374
This commit is contained in:
Jay McCarthy 2005-11-22 21:51:22 +00:00
parent b172954a54
commit 9875ed685e
4 changed files with 517 additions and 396 deletions

View File

@ -20,358 +20,353 @@
responders-servlets-refreshed responders-servlet-loading responders-servlet
responders-file-not-found
timeouts-servlet-connection timeouts-default-servlet)
;; ************************************************************
;; ************************************************************
;; SERVING SERVLETS
;; 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)])))))
;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string))
;; read the bindings and handle any exceptions
(define (read-bindings/handled conn meth uri headers)
(with-handlers ([exn? (lambda (e)
(output-response/method conn (responders-servlet-loading uri e) meth)
'())])
(read-bindings conn meth uri headers)))
;; servlet-content-producer/path: connection request url -> void
;; 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
(define (servlet-content-producer/path conn req uri)
(with-handlers (;; couldn't find the servlet
[exn:fail:filesystem:exists:servlet?
(lambda (the-exn)
(output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))]
;; servlet won't load (e.g. syntax error)
[(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]
[current-servlet-continuation-expiration-handler
(make-default-servlet-continuation-expiration-handler)]
[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)])
(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))))
;; 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-continuation-expiration-handler : -> (request -> response)
(define (make-default-servlet-continuation-expiration-handler)
(lambda (req)
(send/back
(responders-file-not-found
(request-uri req)))))
;; make-default-server-instance-expiration-handler : -> (request -> response)
(define (make-default-servlet-instance-expiration-handler)
(lambda (req)
(responders-file-not-found
(request-uri req))))
;; make-servlet-exception-handler: servlet-instance -> 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)
(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)))))
;; 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))))))
;; 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)]
[default-servlet-continuation-expiration-handler
(make-default-servlet-continuation-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)
((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))))))
;; ************************************************************
;; ************************************************************
;; Paul's ugly loading code:
;; cached-load : path -> script, namespace
;; 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)))))
;; exn:i/o:filesystem:servlet-not-found =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(define-struct (exn:fail:filesystem:exists:servlet
exn:fail:filesystem:exists) ())
;; reload-servlet-script : str -> cache-entry
;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
(define (reload-servlet-script servlet-filename)
(cond
[(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)
;; given a string path to a filename attempt to load a servlet
;; A servlet-file will contain either
;;;; 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
(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)]))))))
(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)
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)])))))
;; ************************************************************
;; ************************************************************
;; SERVING SERVLETS
;; 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)])))))
;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string))
;; read the bindings and handle any exceptions
(define (read-bindings/handled conn meth uri headers)
(with-handlers ([exn? (lambda (e)
(output-response/method conn (responders-servlet-loading uri e) meth)
'())])
(read-bindings conn meth uri headers)))
;; servlet-content-producer/path: connection request url -> void
;; 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
(define (servlet-content-producer/path conn req uri)
(with-handlers (;; couldn't find the servlet
[exn:fail:filesystem:exists:servlet?
(lambda (the-exn)
(output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))]
;; servlet won't load (e.g. syntax error)
[(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))))
;; 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))))
;; make-servlet-exception-handler: servlet-instance -> 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)
(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)))))
;; 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))))))
;; 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))))))
;; ************************************************************
;; ************************************************************
;; Paul's ugly loading code:
;; cached-load : path -> script, namespace
;; 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)))))
;; exn:i/o:filesystem:servlet-not-found =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(define-struct (exn:fail:filesystem:exists:servlet
exn:fail:filesystem:exists) ())
;; reload-servlet-script : str -> cache-entry
;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
(define (reload-servlet-script servlet-filename)
(cond
[(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)
;; given a string path to a filename attempt to load a servlet
;; A servlet-file will contain either
;;;; 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)
; 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)]))))))
(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)
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)])))))

View File

@ -3,10 +3,12 @@
(lib "etc.ss")
(lib "xml.ss" "xml")
(lib "base64.ss" "net")
(lib "url.ss" "net"))
(lib "url.ss" "net")
(lib "struct.ss"))
(require "util.ss"
"response.ss"
"request-parsing.ss")
"request-parsing.ss"
"servlet-tables.ss")
(provide get-host
extract-binding/single
extract-bindings
@ -23,6 +25,136 @@
(rename get-parsed-bindings request-bindings)
translate-escapes)
;; URL parsing
(provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path))
servlet-url->url-string
servlet-url->url-string/no-continuation
servlet-url->servlet-url/no-extra-path
request->servlet-url
uri->servlet-url)
(define-struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path))
(define (servlet-url->url-string/no-continuation su)
(url->string
(make-url (servlet-url-protocol su)
#f
#f ;(servlet-url-host su)
#f ;(servlet-url-port su)
(append (servlet-url-servlets-root su)
(servlet-url-servlet-path su)
(servlet-url-extra-path su))
empty
#f)))
(define (servlet-url->url-string su)
(url->string
(make-url (servlet-url-protocol su)
#f
#f ;(servlet-url-host su)
#f ;(servlet-url-port su)
(append (reverse (rest (reverse (servlet-url-servlets-root su))))
(list (make-path/param (first (reverse (servlet-url-servlets-root su)))
(format "~a*~a*~a"
(servlet-url-instance-id su)
(servlet-url-k-id su)
(servlet-url-nonce su))))
(servlet-url-servlet-path su)
(servlet-url-extra-path su))
empty
#f)))
(define (servlet-url->servlet-url/no-extra-path su)
(copy-struct servlet-url su
[servlet-url-extra-path empty]))
(define (request->servlet-url req)
(uri->servlet-url (request-uri req)
(request-host-ip req)
(request-host-port req)))
(define uri->servlet-url
(opt-lambda (uri [default-host #f] [default-port #f])
(let-values ([(k-instance k-id k-salt)
(let ([k-parts (continuation-url? uri)])
(if k-parts
(apply values k-parts)
(values #f #f #f)))])
(let loop ([path (url-path uri)]
[servlets-root empty]
[found-servlets-root? #f]
[servlet-path empty]
[found-servlet-path? #f]
[extra-path empty])
#;(printf "~S~n" (list path
servlets-root found-servlets-root?
servlet-path found-servlet-path?
extra-path))
(let ([top (if (empty? path)
#f
(first path))])
(cond
;; Find the servlets-root
[(and top
(not found-servlets-root?)
; XXX: Ack!
(not (or (and (not (empty? servlets-root))
(string=? "servlets" (first (reverse servlets-root))))
(path/param? top))))
(loop (rest path)
(append servlets-root (list top)) #f
servlet-path #f
extra-path)]
;;; if there is a continuation part
[(and top
(not found-servlets-root?)
(path/param? top))
(loop (rest path)
(append servlets-root (list (path/param-path top))) #t
servlet-path #f
extra-path)]
;;; if there is not
[(and top
(not found-servlets-root?)
; XXX: Ack!
(not (empty? servlets-root))
(string=? "servlets" (first (reverse servlets-root))))
(loop path
servlets-root #t
servlet-path #f
extra-path)]
;; Find the servlet path
[(and top
found-servlets-root?
(not found-servlet-path?)
(not (and (string? top)
(regexp-match ".ss$" top))))
(loop (rest path)
servlets-root #t
(append servlet-path (list top)) #f
extra-path)]
[(and top
found-servlets-root?
(not found-servlet-path?)
(and (string? top)
(regexp-match ".ss$" top)))
(loop (rest path)
servlets-root #t
(append servlet-path (list top)) #t
extra-path)]
;; Compute the servlet-url
[(and found-servlets-root?
found-servlet-path?)
(make-servlet-url (url-scheme uri)
(or (url-host uri) default-host)
(or (url-port uri) default-port)
servlets-root
k-instance
k-id
k-salt
servlet-path
path)]
[(empty? path)
(error 'request->servlet-url "Not servlet-url: ~S; parsed: ~S" (url->string uri)
(list path
servlets-root found-servlets-root?
servlet-path found-servlet-path?
extra-path))]))))))
;; get-host : Url (listof (cons Symbol String)) -> Symbol
;; host names are case insesitive---Internet RFC 1034
(define DEFAULT-HOST-NAME '<none>)
@ -33,14 +165,14 @@
=>
(lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))]
[else DEFAULT-HOST-NAME]))
;; get-parsed-bindings : request -> (listof (cons sym str))
(define (get-parsed-bindings r)
(let ([x (request-bindings/raw r)])
(if (list? x)
x
(parse-bindings x))))
;; parse-bindings : (U #f String) -> (listof (cons Symbol String))
(define (parse-bindings raw)
(if (string? raw)
@ -59,7 +191,7 @@
(find-amp (add1 amp-end))))
(find= (add1 key-end)))))))
null))
; extract-binding/single : sym (listof (cons str str)) -> str
(define (extract-binding/single name bindings)
(let ([lst (extract-bindings name bindings)])
@ -68,18 +200,18 @@
(error 'extract-binding/single "~a not found in ~a" name bindings)]
[(null? (cdr lst)) (car lst)]
[else (error 'extract-binding/single "~a occurs multiple times in ~a" name bindings)])))
; extract-bindings : sym (listof (cons str str)) -> (listof str)
(define (extract-bindings name bindings)
(map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
; exists-binding? : sym (listof (cons sym str)) -> bool
; for checkboxes
(define (exists-binding? name bindings)
(if (assq name bindings)
#t
#f))
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
@ -91,15 +223,15 @@
(title . ,title))
(body ,body-attributes
(form ([action ,k-url] [method "post"])
. ,content))))))
,@content))))))
; redirection-status = (make-redirection-status nat str)
(define-struct redirection-status (code message))
(define permanently (make-redirection-status 301 "Moved Permanently"))
(define temporarily (make-redirection-status 302 "Moved Temporarily"))
(define see-other (make-redirection-status 303 "See Other"))
; : str [redirection-status] -> response
(define redirect-to
(opt-lambda (uri [perm/temp permanently])
@ -107,19 +239,19 @@
(redirection-status-message perm/temp)
(current-seconds) #"text/html"
`((location . ,uri)) (list (redirect-page uri)))))
; : str -> str
(define (redirect-page url)
(xexpr->string `(html (head (meta ((http-equiv "refresh") (url ,url)))
"Redirect to " ,url)
(body (p "Redirecting to " (a ([href ,url]) ,url))))))
; make-html-response/incremental : ((string -> void) -> void) -> response/incremental
(define (make-html-response/incremental chunk-maker)
(make-response/incremental
200 "Okay" (current-seconds) #"text/html" '()
chunk-maker))
; : (response -> doesn't) -> void
; to report exceptions that occur later to the browser
; this must be called at the begining of a servlet
@ -131,13 +263,13 @@
(body ([bgcolor "white"])
(p "The following error occured: "
(pre ,(exn->string exn)))))))))
; Authentication
(define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)"))
(define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x))
;:(define match-authentication (type: (str -> (union false (list str str str)))))
; extract-user-pass : (listof (cons sym bytes)) -> (U #f (cons str str))
;; Notes (GregP)
;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
@ -150,19 +282,17 @@
(and pass-pair
(let ([basic-credentials (cdr pass-pair)])
(cond
[(and (basic? basic-credentials)
(match-authentication
(base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials))))
[(and (basic? basic-credentials)
(match-authentication
(base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials))))
)
=> (lambda (user-pass)
(cons (cadr user-pass) (caddr user-pass)))]
[else #f])))))
=> (lambda (user-pass)
(cons (cadr user-pass) (caddr user-pass)))]
[else #f])))))
;; basic?: bytes -> (union (listof bytes) #f)
;; does the second part of the authorization header start with #"Basic "
(define basic?
(let ([basic-regexp (byte-regexp #"^Basic .*")])
(lambda (some-bytes)
(regexp-match basic-regexp some-bytes))))
)
(regexp-match basic-regexp some-bytes)))))

View File

@ -175,8 +175,4 @@
(url-port in-url)
new-path
'()
(url-fragment in-url))))
;; **************************************************
)
(url-fragment in-url)))))

View File

@ -31,6 +31,13 @@
[(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))
;; 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.
(provide/contract
@ -59,14 +66,7 @@
;; current-servlet-continuation-expiration-handler : request -> response
(define current-servlet-continuation-expiration-handler
(make-parameter #f))
;; 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))
;; adjust-timeout! : sec -> void
;; adjust the timeout on the servlet
(define (adjust-timeout! secs)