Limit dispatcher

svn: r13072
2009-01-12 17:44:02 +00:00 · 2009-01-12 17:44:02 +00:00 · ba5b8de58a
commit ba5b8de58a
parent c22b570004
3 changed files with 106 additions and 25 deletions
--- a/collects/web-server/dispatchers/limit.ss
+++ 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)))
--- 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 "<html><body>Unlimited</body></html>"))
+           (request-method req))))
+       #:port 8080)
+
+(do-not-return)
+]
--- 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"].