diff --git a/collects/web-server/dispatchers/limit.ss b/collects/web-server/dispatchers/limit.ss new file mode 100644 index 0000000000..8cfe48cc6e --- /dev/null +++ b/collects/web-server/dispatchers/limit.ss @@ -0,0 +1,46 @@ +#lang scheme +(require "dispatch.ss") +(provide/contract + [interface-version dispatcher-interface-version/c] + [make (number? dispatcher/c . -> . dispatcher/c)]) + +(define interface-version 'v1) +(define (make num inner) + (define-struct in-req (partner reply-ch)) + (define in-ch (make-channel)) + (define-struct out-req (partner)) + (define out-ch (make-channel)) + (define limit-manager + (thread + (lambda () + (let loop ([i 0] + [partners empty]) + (apply sync + (if (< i num) + (handle-evt in-ch + (lambda (req) + (channel-put (in-req-reply-ch req) #t) + (loop (add1 i) + (list* (in-req-partner req) partners)))) + never-evt) + (handle-evt out-ch + (lambda (req) + (loop (sub1 i) + (remq (out-req-partner req) partners)))) + (map (lambda (p) + (handle-evt (thread-dead-evt p) + (lambda _ + (loop (sub1 i) (remq p partners))))) + partners)))))) + (define (in) + (define reply (make-channel)) + (channel-put in-ch (make-in-req (current-thread) reply)) + (channel-get reply)) + (define (out) + (channel-put out-ch (make-out-req (current-thread)))) + (lambda (conn req) + (dynamic-wind + in + (lambda () + (inner conn req)) + out))) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 1622cee48c..efb98175fb 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -388,3 +388,62 @@ a URL that refreshes the password file, servlet cache, etc.} dispatcher/c]{ Returns a dispatcher that prints memory usage on every request. }} + +@; ------------------------------------------------------------ +@section[#:tag "limit.ss"]{Limiting Requests} +@a-dispatcher[web-server/dispatchers/limit + @elem{provides a wrapper dispatcher that limits how many requests are serviced at once.}]{ + +@defproc[(make [limit number?] + [inner dispatcher/c]) + dispatcher/c]{ + Returns a dispatcher that defers to @scheme[inner] for work, but will forward a maximum of @scheme[limit] requests concurrently. +}} + +@(require (for-label + web-server/web-server + web-server/http + (prefix-in limit: web-server/dispatchers/limit) + (prefix-in filter: web-server/dispatchers/dispatch-filter) + (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer))) + +Consider this example: +@schememod[ + scheme + +(require web-server/web-server + web-server/http + web-server/http/response + (prefix-in limit: web-server/dispatchers/limit) + (prefix-in filter: web-server/dispatchers/dispatch-filter) + (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)) + +(serve #:dispatch + (sequencer:make + (filter:make + #rx"/limited" + (limit:make + 5 + (lambda (conn req) + (output-response/method + conn + (make-response/full + 200 "Okay" + (current-seconds) TEXT/HTML-MIME-TYPE + empty + (list (format "hello world ~a" + (sort (build-list 100000 (λ x (random 1000))) + <)))) + (request-method req))))) + (lambda (conn req) + (output-response/method + conn + (make-response/full 200 "Okay" + (current-seconds) TEXT/HTML-MIME-TYPE + empty + (list "Unlimited")) + (request-method req)))) + #:port 8080) + +(do-not-return) +] diff --git a/collects/web-server/scribblings/faq.scrbl b/collects/web-server/scribblings/faq.scrbl index dc9702e062..cb9fc203d5 100644 --- a/collects/web-server/scribblings/faq.scrbl +++ b/collects/web-server/scribblings/faq.scrbl @@ -104,28 +104,4 @@ The Web Server will start on port 443 (which can be overridden with the @exec{-p @section{How do I limit the number of requests serviced at once by the Web Server?} -There is no built-in option for this, but you can easily accomplish it if you assemble your own dispatcher -by wrapping it in @scheme[call-with-semaphore]: -@schemeblock[ -(require - (prefix-in private: - web-server/private/web-server-structs)) -(define (make-limit-dispatcher num inner) - (let ([sem (make-semaphore num)]) - (lambda (conn req) - (parameterize - ([current-custodian - (private:current-server-custodian)]) - (thread - (lambda () - (call-with-semaphore - sem - (lambda () - (inner conn req))))))))) -] - -Once this function is available, rather than providing @scheme[james-gordon] as your dispatcher, you provide: -@scheme[(make-limit-dispatch 50 james-gordon)] (if you only want 50 concurrent requests.) One interesting -application of this pattern is to have a limit on certain kinds of requests. For example, you could have a -limit of 50 servlet requests, but no limit on filesystem requests. - +Refer to @secref["limit.ss"].