From 0030ead39800d8e6a19e8741bf6524ab60d7301e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 13 Jun 2007 20:21:17 +0000 Subject: [PATCH] Extracting timeout related work svn: r6639 --- .../web-server/dispatchers/dispatch-lang.ss | 7 ++---- .../dispatchers/dispatch-passwords.ss | 4 ---- .../dispatchers/dispatch-servlets.ss | 12 +++------- .../dispatchers/dispatch-timeout.ss | 12 ++++++++++ .../docs/reference/dispatchers.scrbl | 24 +++++++++++-------- .../web-server/docs/reference/servlet.scrbl | 1 - .../private/dispatch-server-unit.ss | 1 - collects/web-server/private/request.ss | 3 ++- collects/web-server/private/response.ss | 5 ++-- collects/web-server/run.ss | 3 ++- .../dispatchers/dispatch-passwords-test.ss | 1 - collects/web-server/web-server-unit.ss | 9 ++++--- 12 files changed, 43 insertions(+), 39 deletions(-) create mode 100644 collects/web-server/dispatchers/dispatch-timeout.ss diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 40fa0c71a7..39899c6a40 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -9,7 +9,6 @@ (lib "web-cells.ss" "web-server" "lang") "../private/request-structs.ss" "dispatch.ss" - "../private/connection-manager.ss" "../private/util.ss" "../private/response.ss" "../configuration/namespace.ss" @@ -46,13 +45,13 @@ empty #f)) - ;; XXX url->servlet, get rid of timeout, optional session manager + ; XXX url->servlet + ; XXX optional session manager (define interface-version 'v1) (define/kw (make #:key url->path [make-servlet-namespace (make-make-servlet-namespace)] - [timeouts-servlet-connection (* 60 60 24)] [responders-servlet-loading servlet-loading-responder] [responders-servlet @@ -61,8 +60,6 @@ ;; dispatch : connection request -> void (define (dispatch conn req) (define uri (request-uri req)) - (adjust-connection-timeout! conn timeouts-servlet-connection) - ;; XXX - make timeouts proportional to size of bindings (cond [(extract-session uri) => (lambda (session-id) diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index aeede44105..298f4d63b3 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -7,7 +7,6 @@ "../configuration/responders.ss" "../private/request-structs.ss" "../servlet/basic-auth.ss" - "../private/connection-manager.ss" "../private/response.ss") (provide/contract [interface-version dispatcher-interface-version?]) @@ -17,8 +16,6 @@ (define/kw (make #:key ; XXX Take authorized? function [password-file "passwords"] - ; XXX Move out - [password-connection-timeout 300] [authentication-responder (gen-authentication-responder "forbidden.html")]) (define last-read-time (box #f)) @@ -43,7 +40,6 @@ [(and denied? (access-denied? method path (request-headers/raw req) denied?)) => (lambda (realm) - (adjust-connection-timeout! conn password-connection-timeout) (request-authentication conn method uri authentication-responder realm))] diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 94674b033f..0a3bfe5a7d 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -31,18 +31,12 @@ servlet-loading-responder] [responders-servlet (gen-servlet-responder "servlet-error.html")] - [timeouts-servlet-connection (* 60 60 24)] [timeouts-default-servlet 30]) ;; servlet-content-producer: connection request -> void (define (servlet-content-producer conn req) (define meth (request-method 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 [(continuation-url? uri) => (match-lambda @@ -206,7 +200,7 @@ (current-namespace) (create-timeout-manager default-servlet-instance-expiration-handler - timeouts-servlet-connection + timeout timeout) (v1.module->v1.lambda timeout start)))] [(v2 v2-transitional) ; XXX: Depreciate v2-transitional @@ -223,8 +217,8 @@ (current-namespace) (create-timeout-manager default-servlet-instance-expiration-handler - timeouts-servlet-connection - timeouts-servlet-connection) + timeouts-default-servlet + 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)]))) diff --git a/collects/web-server/dispatchers/dispatch-timeout.ss b/collects/web-server/dispatchers/dispatch-timeout.ss new file mode 100644 index 0000000000..6dea262cdf --- /dev/null +++ b/collects/web-server/dispatchers/dispatch-timeout.ss @@ -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))) \ No newline at end of file diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index 101743ffea..6a2ecd02e4 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -95,6 +95,20 @@ that invokes a sequence of dispatchers until one applies. calls @scheme[next-dispatcher]. If no @scheme[dispatcher] applies, 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} @@ -173,7 +187,6 @@ for transparent logging of requests. that performs HTTP Basic authentication filtering. @defproc[(make [#:password-file password-file path-string? "passwords"] - [#:password-connection-timeout password-connection-timeout integer? 300] [#:authentication-responder authentication-responder ((url url?) (header (cons/c symbol? string?)) . -> . response?) @@ -184,7 +197,6 @@ that performs HTTP Basic authentication filtering. file used by the dispatcher. 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 they are included in @scheme[password-file]. If they are not, @scheme[authentication-responder] is called with a @scheme[header] that @@ -259,10 +271,6 @@ that runs servlets written in Scheme. responders-servlet ((url url?) (exn any/c) . -> . response?) (gen-servlet-responder "servlet-error.html")] - [#:timeouts-servlet-connection - timeouts-servlet-connection - integer? - (* 60 60 24)] [#:timeouts-default-servlet timeouts-default-servlet integer? @@ -273,7 +281,6 @@ that runs servlets written in Scheme. code cache. 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 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]. @@ -291,16 +298,13 @@ that runs servlets written in Scheme. @file{dispatchers/dispatch-lang.ss} defines a dispatcher constructor 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?] [#:make-servlet-namespace make-servlet-namespace 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 responders-servlet (gen-servlet-responder "servlet-error.html")]) 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 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]. diff --git a/collects/web-server/docs/reference/servlet.scrbl b/collects/web-server/docs/reference/servlet.scrbl index 1cd430f787..027dcaee25 100644 --- a/collects/web-server/docs/reference/servlet.scrbl +++ b/collects/web-server/docs/reference/servlet.scrbl @@ -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]. } -@; XXX Subtypes of request? @defstruct[request ([method symbol?] [uri url?] [headers/raw (listof header?)] diff --git a/collects/web-server/private/dispatch-server-unit.ss b/collects/web-server/private/dispatch-server-unit.ss index 692cfb56b6..ff67a41431 100644 --- a/collects/web-server/private/dispatch-server-unit.ss +++ b/collects/web-server/private/dispatch-server-unit.ss @@ -66,7 +66,6 @@ (raise e))]) (let connection-loop () (define-values (req close?) (config:read-request conn config:port port-addresses)) - (adjust-connection-timeout! conn config:initial-connection-timeout) (config:dispatch conn req) (unless (connection-close? conn) (set-connection-close?! conn close?)) diff --git a/collects/web-server/private/request.ss b/collects/web-server/private/request.ss index 7383f82d23..d543fa6121 100644 --- a/collects/web-server/private/request.ss +++ b/collects/web-server/private/request.ss @@ -28,7 +28,8 @@ (define _ (match (headers-assq* #"Content-Length" headers) [(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))))] [#f (void)])) diff --git a/collects/web-server/private/response.ss b/collects/web-server/private/response.ss index 9d7043afaa..023d6ca865 100644 --- a/collects/web-server/private/response.ss +++ b/collects/web-server/private/response.ss @@ -203,9 +203,8 @@ (make-header #"Content-Range" (string->bytes/utf-8 (format "bytes ~a-~a/~a" start end total-len)))))) (output-headers+response/basic conn bresp) (when (eq? method 'get) - ; Give it one second per byte. - ; XXX Move out - (adjust-connection-timeout! conn len) + ; XXX Move out? + (adjust-connection-timeout! conn len) ; Give it one second per byte. (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))]) (call-with-input-file file-path (lambda (i-port) diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss index 8e996d9059..43ac8dffa5 100644 --- a/collects/web-server/run.ss +++ b/collects/web-server/run.ss @@ -6,6 +6,7 @@ (lib "responders.ss" "web-server" "configuration") (lib "mime-types.ss" "web-server" "private") (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 filter: (lib "dispatch-filter.ss" "web-server" "dispatchers")) (prefix lift: (lib "dispatch-lift.ss" "web-server" "dispatchers")) @@ -40,10 +41,10 @@ (serve #:port (port) #:dispatch (sequencer:make + (timeout:make (* 5 60)) (filter:make #rx"\\.ss" (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 (gen-servlet-responder servlet-error-file))) (files:make #:url->path url->path diff --git a/collects/web-server/tests/dispatchers/dispatch-passwords-test.ss b/collects/web-server/tests/dispatchers/dispatch-passwords-test.ss index cfd8dbb362..9005feb178 100644 --- a/collects/web-server/tests/dispatchers/dispatch-passwords-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-passwords-test.ss @@ -28,7 +28,6 @@ (define (runt applies? authorized?) (let/ec esc (define-values (_ d) (passwords:make #:password-file test-passwords - #:password-connection-timeout +inf.0 #:authentication-responder (lambda (u h) (esc h)))) (define-values (c i o) (make-mock-connection #"")) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 5215edade7..6bf07e146d 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -12,6 +12,7 @@ (prefix http: "private/request.ss")) (require (prefix fsmap: "dispatchers/filesystem-map.ss") (prefix sequencer: "dispatchers/dispatch-sequencer.ss") + (prefix timeout: (lib "dispatch-timeout.ss" "web-server" "dispatchers")) (prefix passwords: "dispatchers/dispatch-passwords.ss") (prefix files: "dispatchers/dispatch-files.ss") (prefix servlets: "dispatchers/dispatch-servlets.ss") @@ -49,13 +50,14 @@ ;; host-info->dispatcher : host-info -> conn request -> void (define (host-info->dispatcher host-info) (sequencer:make + (timeout:make initial-connection-timeout) (log:make #:log-format (host-log-format host-info) #:log-path (host-log-path host-info)) (let-values ([(update-password-cache! password-check) (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)))]) (sequencer:make + (timeout:make (timeouts-password (host-timeouts host-info))) password-check (path-procedure:make "/conf/refresh-passwords" (lambda _ @@ -73,7 +75,6 @@ (fsmap:make-url->path (paths-servlet (host-paths host-info)))) #:responders-servlet-loading (responders-servlet-loading (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)))]) (sequencer:make (path-procedure:make "/conf/refresh-servlets" @@ -82,7 +83,9 @@ ((responders-servlets-refreshed (host-responders host-info))))) (filter:make #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))) #:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info))) #:indices (host-indices host-info))