Add rate limiting to httpd.

httpd-core.scm

@@ -65,7 +65,12 @@
 
 (define (httpd options)
   (let ((port (httpd-options-port options))
-	(root-dir (httpd-options-root-directory options)))
+	(root-dir (httpd-options-root-directory options))
+	(rate-limiter
+	 (cond
+	  ((httpd-options-simultaneous-requests options)
+	   => make-rate-limiter)
+	  (else #f))))
     (init-http-log!)
     (with-cwd
      root-dir
@@ -74,18 +79,54 @@
       ;; Why is the output socket unbuffered? So that if the client
       ;; closes the connection, we won't lose when we try to close the
       ;; socket by trying to flush the output buffer.
-      (lambda (sock addr)		; Called once for every connection.
+      (lambda (sock addr)
-	(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+	(if rate-limiter
-	(fork-thread 
+	    (begin
-	 (lambda ()	
+	      (rate-limit-block rate-limiter)
-	   (with-current-input-port 
+	      (rate-limit-open rate-limiter)))
-	    (socket:inport sock)	; bind the
+
-	    (with-current-output-port 
+	(with-fatal-error-handler
-	     (socket:outport sock)	; stdio ports, &
+	 (lambda (c decline)
-	     (set-port-buffering (current-input-port) bufpol/none)
+	   (http-log "error during connection negotiation~%")
-	     (process-toplevel-request sock options)
+	   (if rate-limiter
-	     (close-socket sock)))	; do it.
+	       (rate-limit-close rate-limiter)))
-	   )))
+	 (call-with-values
+	  (lambda ()
+	    (socket-address->internet-address (socket-remote-address sock)))
+	  (lambda (host-address service-port)
+	    (if (and rate-limiter *http-log?*)
+		(http-log "<~a>~a: concurrent request #~a~%"
+			  (pid)
+			  (format-internet-host-address host-address)
+			  (rate-limiter-current-requests rate-limiter)))
+
+	    (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+	    (fork-thread 
+	     (lambda ()	
+	       (with-current-input-port 
+		(socket:inport sock)
+		(with-current-output-port 
+		 (socket:outport sock)
+		 (set-port-buffering (current-input-port) bufpol/none)
+		 (process-toplevel-request sock host-address options)))
+	       (if *http-log?*
+		   (http-log "<~a>~a [closing]~%"
+			     (pid)
+			     (format-internet-host-address host-address)))
+	       (with-fatal-error-handler
+		(lambda (c decline)
+		  (if *http-log?*
+		      (http-log "<~a>~a [error closing (~a)]~%"
+				(pid)
+				(format-internet-host-address host-address)
+				c)))
+		(close-socket sock))
+	       (if rate-limiter
+		   (rate-limit-close rate-limiter))
+	       (if *http-log?*
+		   (http-log "<~a>~a [closed]~%"
+			     (pid)
+			     (format-internet-host-address host-address)))))))))
       port))))
 
 ;;; Top-level http request processor
@@ -100,7 +141,7 @@
 ;;; this code to some other Scheme, you'd really have to sit down and think
 ;;; about this issue for a minute.
 
-(define (process-toplevel-request sock options)
+(define (process-toplevel-request sock host-address options)
   ;; This top-level error-handler catches *all* uncaught errors and warnings.
   ;; If the error condition is a reportable HTTP error, we send a reply back 
   ;; to the client. In any event, we abort the transaction, and return from
@@ -108,13 +149,26 @@
   ;;
   ;; We *oughta* map non-http-errors into replies anyway.
   (with-fatal-error-handler (lambda (c decline)		; No call to decline
-			      (http-log "Error! ~s~%" c)
+			      (http-log "<~a>~a: error: ~s~%"
+					(pid)
+					(format-internet-host-address host-address)
+					c)
 			      (if (http-error? c)	; -- we handle all.
 				  (apply (lambda (reply-code req . args)
 					   (apply send-http-error-reply
 						  reply-code req options
 						  args))
-					 (condition-stuff c))))
+					 (condition-stuff c))
+				  (with-fatal-error-handler
+				   (lambda (c decline)
+				     (http-log "<~a>~a [error shutting down: ~s]~%"
+					       (pid)
+					       (format-internet-host-address host-address)
+					       c))
+				   (shutdown-socket sock shutdown/sends+receives)
+				   (http-log "<~a>~a [shut down]~%"
+					     (pid)
+					     (format-internet-host-address host-address)))))
 
     (let ((req (with-fatal-error-handler	; Map syntax errors
 	           (lambda (c decline)		; to http errors.
@@ -189,7 +243,8 @@
 	 (lambda ()
 	   (socket-address->internet-address (socket-remote-address sock)))
 	 (lambda (host-address service-port)
-	   (http-log "~a: ~a~%"
+	   (http-log "<~a>~a: ~a~%"
+		     (pid)
 		     (format-internet-host-address host-address)
 		     line))))
     

modules.scm

@@ -282,6 +282,20 @@
 	  httpd-options-server-admin
 	  httpd-options-simultaneous-requests))
 
+(define-interface rate-limit-interface
+  (export make-rate-limiter
+	  rate-limit-block
+	  rate-limit-open
+	  rate-limit-close
+	  rate-limiter-current-requests))
+
+(define-structure rate-limit rate-limit-interface
+  (open scheme
+	define-record-types
+	locks
+	signals)
+  (files rate-limit))
+  
 (define-structure httpd-core httpd-core-interface
   (open threads locks
 	thread-fluids               ; fork-thread
@@ -304,6 +318,7 @@
 	format-net
 	sunet-utilities
 	httpd-read-options
+	rate-limit
 	scheme)
   (files httpd-core))
 

rate-limit.scm

@@ -0,0 +1,58 @@
+;;; Rate limiting -*- Scheme -*-
+;;; Copyright (c) 2002 by Mike Sperber.
+
+(define-record-type rate-limiter :rate-limiter
+  (really-make-rate-limiter simultaneous-requests
+			    access-lock
+			    block-lock
+			    current-requests)
+  rate-limiter?
+  (simultaneous-requests rate-limiter-simultaneous-requests)
+  (access-lock rate-limiter-access-lock)
+  (block-lock rate-limiter-block-lock)
+  (current-requests rate-limiter-current-requests-unsafe
+		    set-rate-limiter-current-requests!))
+
+(define (make-rate-limiter simultaneous-requests)
+  (really-make-rate-limiter simultaneous-requests
+			    (make-lock)
+			    (make-lock)
+			    0))
+
+(define (rate-limit-block rate-limiter)
+  (obtain-lock (rate-limiter-block-lock rate-limiter)))
+
+(define (rate-limit-open rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (+ 1 (rate-limiter-current-requests-unsafe rate-limiter))))
+    (set-rate-limiter-current-requests! rate-limiter
+					current-requests)
+    (if (>= current-requests
+	    (rate-limiter-simultaneous-requests rate-limiter))
+	(maybe-obtain-lock (rate-limiter-block-lock rate-limiter))
+	(release-lock (rate-limiter-block-lock rate-limiter))))
+  (release-lock (rate-limiter-access-lock rate-limiter)))
+
+(define (rate-limit-close rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (- (rate-limiter-current-requests-unsafe rate-limiter) 1)))
+    (if (negative? current-requests)
+	(error "rate-limiter: too many close operations"
+	       rate-limiter))
+    (set-rate-limiter-current-requests! rate-limiter
+					current-requests)
+    (if (= current-requests
+	   (- (rate-limiter-simultaneous-requests rate-limiter)
+	      1))
+	;; we just came back into range
+	(release-lock (rate-limiter-block-lock rate-limiter))))
+  (release-lock (rate-limiter-access-lock rate-limiter)))
+
+(define (rate-limiter-current-requests rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (rate-limiter-current-requests-unsafe rate-limiter)))
+    (release-lock (rate-limiter-access-lock rate-limiter))
+    current-requests))