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

Extracting timeout related work

Browse Source 
svn: r6639
This commit is contained in:
Jay McCarthy 2007-06-13 20:21:17 +00:00
parent e657ff19a6
commit 0030ead398
12 changed files with 43 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -9,7 +9,6 @@
(lib "web-cells.ss" "web-server" "lang") (lib "web-cells.ss" "web-server" "lang")
"../private/request-structs.ss" "../private/request-structs.ss"
"dispatch.ss" "dispatch.ss"
"../private/connection-manager.ss"
"../private/util.ss" "../private/util.ss"
"../private/response.ss" "../private/response.ss"
"../configuration/namespace.ss" "../configuration/namespace.ss"
@ -46,13 +45,13 @@
empty empty
#f)) #f))
;; XXX url->servlet, get rid of timeout, optional session manager ; XXX url->servlet
; XXX optional session manager
(define interface-version 'v1) (define interface-version 'v1)
(define/kw (make #:key (define/kw (make #:key
url->path url->path
[make-servlet-namespace [make-servlet-namespace
(make-make-servlet-namespace)] (make-make-servlet-namespace)]
[timeouts-servlet-connection (* 60 60 24)]
[responders-servlet-loading [responders-servlet-loading
servlet-loading-responder] servlet-loading-responder]
[responders-servlet [responders-servlet
@ -61,8 +60,6 @@
;; dispatch : connection request -> void ;; dispatch : connection request -> void
(define (dispatch conn req) (define (dispatch conn req)
(define uri (request-uri req)) (define uri (request-uri req))
(adjust-connection-timeout! conn timeouts-servlet-connection)
;; XXX - make timeouts proportional to size of bindings
(cond (cond
[(extract-session uri) [(extract-session uri)
=> (lambda (session-id) => (lambda (session-id)

4
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -7,7 +7,6 @@
"../configuration/responders.ss" "../configuration/responders.ss"
"../private/request-structs.ss" "../private/request-structs.ss"
"../servlet/basic-auth.ss" "../servlet/basic-auth.ss"
"../private/connection-manager.ss"
"../private/response.ss") "../private/response.ss")
(provide/contract (provide/contract
[interface-version dispatcher-interface-version?]) [interface-version dispatcher-interface-version?])
@ -17,8 +16,6 @@
(define/kw (make #:key (define/kw (make #:key
; XXX Take authorized? function ; XXX Take authorized? function
[password-file "passwords"] [password-file "passwords"]
; XXX Move out
[password-connection-timeout 300]
[authentication-responder [authentication-responder
(gen-authentication-responder "forbidden.html")]) (gen-authentication-responder "forbidden.html")])
(define last-read-time (box #f)) (define last-read-time (box #f))
@ -43,7 +40,6 @@
[(and denied? [(and denied?
(access-denied? method path (request-headers/raw req) denied?)) (access-denied? method path (request-headers/raw req) denied?))
=> (lambda (realm) => (lambda (realm)
(adjust-connection-timeout! conn password-connection-timeout)
(request-authentication conn method uri (request-authentication conn method uri
authentication-responder authentication-responder
realm))] realm))]

12
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -31,18 +31,12 @@
servlet-loading-responder] servlet-loading-responder]
[responders-servlet [responders-servlet
(gen-servlet-responder "servlet-error.html")] (gen-servlet-responder "servlet-error.html")]
[timeouts-servlet-connection (* 60 60 24)]
[timeouts-default-servlet 30]) [timeouts-default-servlet 30])
;; servlet-content-producer: connection request -> void ;; servlet-content-producer: connection request -> void
(define (servlet-content-producer conn req) (define (servlet-content-producer conn req)
(define meth (request-method req)) (define meth (request-method req))
(define uri (request-uri req)) (define uri (request-uri req))
;; XXX - make timeouts proportional to size of bindings
; XXX Move outside
(adjust-connection-timeout!
conn
timeouts-servlet-connection)
(cond (cond
[(continuation-url? uri) [(continuation-url? uri)
=> (match-lambda => (match-lambda
@ -206,7 +200,7 @@
(current-namespace) (current-namespace)
(create-timeout-manager (create-timeout-manager
default-servlet-instance-expiration-handler default-servlet-instance-expiration-handler
timeouts-servlet-connection timeout
timeout) timeout)
(v1.module->v1.lambda timeout start)))] (v1.module->v1.lambda timeout start)))]
[(v2 v2-transitional) ; XXX: Depreciate v2-transitional [(v2 v2-transitional) ; XXX: Depreciate v2-transitional
@ -223,8 +217,8 @@
(current-namespace) (current-namespace)
(create-timeout-manager (create-timeout-manager
default-servlet-instance-expiration-handler default-servlet-instance-expiration-handler
timeouts-servlet-connection timeouts-default-servlet
timeouts-servlet-connection) timeouts-default-servlet)
(v0.response->v1.lambda s a-path))] (v0.response->v1.lambda s a-path))]
[else [else
(error '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)])))

12
collects/web-server/dispatchers/dispatch-timeout.ss Normal file
View File

@ -0,0 +1,12 @@
(module dispatch-timeout mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss"
"../private/connection-manager.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make (integer? . -> . dispatcher?)])
(define interface-version 'v1)
(define ((make new-timeout) conn req)
(adjust-connection-timeout! conn new-timeout)
(next-dispatcher)))

24
collects/web-server/docs/reference/dispatchers.scrbl
View File

@ -96,6 +96,20 @@ that invokes a sequence of dispatchers until one applies.
then it calls @scheme[next-dispatcher] itself. then it calls @scheme[next-dispatcher] itself.
} }
@; XXX Kind of timeout that is proportional to bindings
@; ------------------------------------------------------------
@section[#:tag "dispatch-timeout.ss"]{Timeouts}
@file{dispatchers/dispatch-timeout.ss} defines a dispatcher constructor
that changes the timeout on the connection and calls the next
dispatcher.
@defproc[(make [new-timeout integer?])
dispatcher?]{
Changes the timeout on the connection with @scheme[adjust-connection-timeout!]
called with @scheme[new-timeout].
}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section[#:tag "dispatch-lift.ss"]{Lifting Procedures} @section[#:tag "dispatch-lift.ss"]{Lifting Procedures}
@ -173,7 +187,6 @@ for transparent logging of requests.
that performs HTTP Basic authentication filtering. that performs HTTP Basic authentication filtering.
@defproc[(make [#:password-file password-file path-string? "passwords"] @defproc[(make [#:password-file password-file path-string? "passwords"]
[#:password-connection-timeout password-connection-timeout integer? 300]
[#:authentication-responder [#:authentication-responder
authentication-responder authentication-responder
((url url?) (header (cons/c symbol? string?)) . -> . response?) ((url url?) (header (cons/c symbol? string?)) . -> . response?)
@ -184,7 +197,6 @@ that performs HTTP Basic authentication filtering.
file used by the dispatcher. file used by the dispatcher.
The dispatcher that is returned does the following: The dispatcher that is returned does the following:
Extends connection timeout by @scheme[password-connection-timeout].
Checks if the request contains Basic authentication credentials, and that Checks if the request contains Basic authentication credentials, and that
they are included in @scheme[password-file]. If they are not, they are included in @scheme[password-file]. If they are not,
@scheme[authentication-responder] is called with a @scheme[header] that @scheme[authentication-responder] is called with a @scheme[header] that
@ -259,10 +271,6 @@ that runs servlets written in Scheme.
responders-servlet responders-servlet
((url url?) (exn any/c) . -> . response?) ((url url?) (exn any/c) . -> . response?)
(gen-servlet-responder "servlet-error.html")] (gen-servlet-responder "servlet-error.html")]
[#:timeouts-servlet-connection
timeouts-servlet-connection
integer?
(* 60 60 24)]
[#:timeouts-default-servlet [#:timeouts-default-servlet
timeouts-default-servlet timeouts-default-servlet
integer? integer?
@ -273,7 +281,6 @@ that runs servlets written in Scheme.
code cache. code cache.
The dispatcher does the following: The dispatcher does the following:
Extends the timeout of the connection by @scheme[timeouts-servlet-connection].
If the request URL contains a continuation reference, then it is invoked with the If the request URL contains a continuation reference, then it is invoked with the
request. Otherwise, @scheme[url->path] is used to resolve the URL to a path. request. Otherwise, @scheme[url->path] is used to resolve the URL to a path.
The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace]. The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace].
@ -291,16 +298,13 @@ that runs servlets written in Scheme.
@file{dispatchers/dispatch-lang.ss} defines a dispatcher constructor @file{dispatchers/dispatch-lang.ss} defines a dispatcher constructor
that runs servlets written in the Web Language. that runs servlets written in the Web Language.
@; XXX Don't include timeout logic in here, put it outside.
@defproc[(make [#:url->path url->path url->path?] @defproc[(make [#:url->path url->path url->path?]
[#:make-servlet-namespace make-servlet-namespace [#:make-servlet-namespace make-servlet-namespace
make-servlet-namespace? make-servlet-namespace?
(make-make-servlet-namespace)] (make-make-servlet-namespace)]
[#:timeouts-servlet-connection timeouts-servlet-connection integer? (* 60 60 24)]
[#:responders-servlet-loading responders-servlet-loading servlet-loading-responder] [#:responders-servlet-loading responders-servlet-loading servlet-loading-responder]
[#:responders-servlet responders-servlet (gen-servlet-responder "servlet-error.html")]) [#:responders-servlet responders-servlet (gen-servlet-responder "servlet-error.html")])
dispatcher?]{ dispatcher?]{
Extends the timeout of the connection by @scheme[timeouts-servlet-connection].
If the request URL contains a serialized continuation, then it is invoked with the If the request URL contains a serialized continuation, then it is invoked with the
request. Otherwise, @scheme[url->path] is used to resolve the URL to a path. request. Otherwise, @scheme[url->path] is used to resolve the URL to a path.
The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace]. The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace].

1
collects/web-server/docs/reference/servlet.scrbl
View File

@ -107,7 +107,6 @@ related to HTTP request data structures.
Returns the binding with an id equal to @scheme[id] from @scheme[binds] or @scheme[#f]. Returns the binding with an id equal to @scheme[id] from @scheme[binds] or @scheme[#f].
} }
@; XXX Subtypes of request?
@defstruct[request ([method symbol?] @defstruct[request ([method symbol?]
[uri url?] [uri url?]
[headers/raw (listof header?)] [headers/raw (listof header?)]

1
collects/web-server/private/dispatch-server-unit.ss
View File

@ -66,7 +66,6 @@
(raise e))]) (raise e))])
(let connection-loop () (let connection-loop ()
(define-values (req close?) (config:read-request conn config:port port-addresses)) (define-values (req close?) (config:read-request conn config:port port-addresses))
(adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req) (config:dispatch conn req)
(unless (connection-close? conn) (unless (connection-close? conn)
(set-connection-close?! conn close?)) (set-connection-close?! conn close?))

1
collects/web-server/private/request.ss
View File

@ -29,6 +29,7 @@
(match (headers-assq* #"Content-Length" headers) (match (headers-assq* #"Content-Length" headers)
[(struct header (f v)) [(struct header (f v))
; Give it one second per byte (with 5 second minimum... a bit arbitrary) ; Give it one second per byte (with 5 second minimum... a bit arbitrary)
; XXX Can this be abstracted?
(adjust-connection-timeout! conn (max 5 (string->number (bytes->string/utf-8 v))))] (adjust-connection-timeout! conn (max 5 (string->number (bytes->string/utf-8 v))))]
[#f [#f
(void)])) (void)]))

5
collects/web-server/private/response.ss
View File

@ -203,9 +203,8 @@
(make-header #"Content-Range" (string->bytes/utf-8 (format "bytes ~a-~a/~a" start end total-len)))))) (make-header #"Content-Range" (string->bytes/utf-8 (format "bytes ~a-~a/~a" start end total-len))))))
(output-headers+response/basic conn bresp) (output-headers+response/basic conn bresp)
(when (eq? method 'get) (when (eq? method 'get)
; Give it one second per byte. ; XXX Move out?
; XXX Move out (adjust-connection-timeout! conn len) ; Give it one second per byte.
(adjust-connection-timeout! conn len)
(with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))]) (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))])
(call-with-input-file file-path (call-with-input-file file-path
(lambda (i-port) (lambda (i-port)

3
collects/web-server/run.ss
View File

@ -6,6 +6,7 @@
(lib "responders.ss" "web-server" "configuration") (lib "responders.ss" "web-server" "configuration")
(lib "mime-types.ss" "web-server" "private") (lib "mime-types.ss" "web-server" "private")
(prefix fsmap: (lib "filesystem-map.ss" "web-server" "dispatchers")) (prefix fsmap: (lib "filesystem-map.ss" "web-server" "dispatchers"))
(prefix timeout: (lib "dispatch-timeout.ss" "web-server" "dispatchers"))
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers")) (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
(prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers")) (prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers"))
(prefix lift: (lib "dispatch-lift.ss" "web-server" "dispatchers")) (prefix lift: (lib "dispatch-lift.ss" "web-server" "dispatchers"))
@ -40,10 +41,10 @@
(serve #:port (port) (serve #:port (port)
#:dispatch #:dispatch
(sequencer:make (sequencer:make
(timeout:make (* 5 60))
(filter:make (filter:make
#rx"\\.ss" #rx"\\.ss"
(lang:make #:url->path (fsmap:make-url->valid-path url->path) (lang:make #:url->path (fsmap:make-url->valid-path url->path)
#:timeouts-servlet-connection 86400
#:responders-servlet-loading (gen-servlet-responder servlet-error-file) #:responders-servlet-loading (gen-servlet-responder servlet-error-file)
#:responders-servlet (gen-servlet-responder servlet-error-file))) #:responders-servlet (gen-servlet-responder servlet-error-file)))
(files:make #:url->path url->path (files:make #:url->path url->path

1
collects/web-server/tests/dispatchers/dispatch-passwords-test.ss
View File

@ -28,7 +28,6 @@
(define (runt applies? authorized?) (define (runt applies? authorized?)
(let/ec esc (let/ec esc
(define-values (_ d) (passwords:make #:password-file test-passwords (define-values (_ d) (passwords:make #:password-file test-passwords
#:password-connection-timeout +inf.0
#:authentication-responder #:authentication-responder
(lambda (u h) (esc h)))) (lambda (u h) (esc h))))
(define-values (c i o) (make-mock-connection #"")) (define-values (c i o) (make-mock-connection #""))

9
collects/web-server/web-server-unit.ss
View File

@ -12,6 +12,7 @@
(prefix http: "private/request.ss")) (prefix http: "private/request.ss"))
(require (prefix fsmap: "dispatchers/filesystem-map.ss") (require (prefix fsmap: "dispatchers/filesystem-map.ss")
(prefix sequencer: "dispatchers/dispatch-sequencer.ss") (prefix sequencer: "dispatchers/dispatch-sequencer.ss")
(prefix timeout: (lib "dispatch-timeout.ss" "web-server" "dispatchers"))
(prefix passwords: "dispatchers/dispatch-passwords.ss") (prefix passwords: "dispatchers/dispatch-passwords.ss")
(prefix files: "dispatchers/dispatch-files.ss") (prefix files: "dispatchers/dispatch-files.ss")
(prefix servlets: "dispatchers/dispatch-servlets.ss") (prefix servlets: "dispatchers/dispatch-servlets.ss")
@ -49,13 +50,14 @@
;; host-info->dispatcher : host-info -> conn request -> void ;; host-info->dispatcher : host-info -> conn request -> void
(define (host-info->dispatcher host-info) (define (host-info->dispatcher host-info)
(sequencer:make (sequencer:make
(timeout:make initial-connection-timeout)
(log:make #:log-format (host-log-format host-info) (log:make #:log-format (host-log-format host-info)
#:log-path (host-log-path host-info)) #:log-path (host-log-path host-info))
(let-values ([(update-password-cache! password-check) (let-values ([(update-password-cache! password-check)
(passwords:make #:password-file (host-passwords host-info) (passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info)))]) #:authentication-responder (responders-authentication (host-responders host-info)))])
(sequencer:make (sequencer:make
(timeout:make (timeouts-password (host-timeouts host-info)))
password-check password-check
(path-procedure:make "/conf/refresh-passwords" (path-procedure:make "/conf/refresh-passwords"
(lambda _ (lambda _
@ -73,7 +75,6 @@
(fsmap:make-url->path (paths-servlet (host-paths host-info)))) (fsmap:make-url->path (paths-servlet (host-paths host-info))))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info)) #:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info)) #:responders-servlet (responders-servlet (host-responders host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))]) #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))])
(sequencer:make (sequencer:make
(path-procedure:make "/conf/refresh-servlets" (path-procedure:make "/conf/refresh-servlets"
@ -82,7 +83,9 @@
((responders-servlets-refreshed (host-responders host-info))))) ((responders-servlets-refreshed (host-responders host-info)))))
(filter:make (filter:make
#rx"^/servlets" #rx"^/servlets"
servlet-dispatch))) (sequencer:make
(timeout:make (timeouts-servlet-connection (host-timeouts host-info)))
servlet-dispatch))))
(files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info))) (files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info)))
#:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info))) #:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info)))
#:indices (host-indices host-info)) #:indices (host-indices host-info))