From 9a2be969d54c127de883f29c3f2e5d89ae3c9c62 Mon Sep 17 00:00:00 2001 From: sperber Date: Fri, 1 Mar 2002 08:54:48 +0000 Subject: [PATCH] Add rate limiting to httpd. --- httpd-core.scm | 89 ++++++++++++++++++++++++++++++++++++++++---------- modules.scm | 15 +++++++++ rate-limit.scm | 58 ++++++++++++++++++++++++++++++++ 3 files changed, 145 insertions(+), 17 deletions(-) create mode 100644 rate-limit.scm diff --git a/httpd-core.scm b/httpd-core.scm index 71ed59c..40a7baf 100644 --- a/httpd-core.scm +++ b/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. - (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering - (fork-thread - (lambda () - (with-current-input-port - (socket:inport sock) ; bind the - (with-current-output-port - (socket:outport sock) ; stdio ports, & - (set-port-buffering (current-input-port) bufpol/none) - (process-toplevel-request sock options) - (close-socket sock))) ; do it. - ))) + (lambda (sock addr) + (if rate-limiter + (begin + (rate-limit-block rate-limiter) + (rate-limit-open rate-limiter))) + + (with-fatal-error-handler + (lambda (c decline) + (http-log "error during connection negotiation~%") + (if rate-limiter + (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)))) diff --git a/modules.scm b/modules.scm index a1faa5a..85e3aa5 100644 --- a/modules.scm +++ b/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)) diff --git a/rate-limit.scm b/rate-limit.scm new file mode 100644 index 0000000..5a461c6 --- /dev/null +++ b/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))