Add rate limiting to httpd.
This commit is contained in:
parent
d9fc32433d
commit
9a2be969d5
|
@ -65,7 +65,12 @@
|
||||||
|
|
||||||
(define (httpd options)
|
(define (httpd options)
|
||||||
(let ((port (httpd-options-port 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!)
|
(init-http-log!)
|
||||||
(with-cwd
|
(with-cwd
|
||||||
root-dir
|
root-dir
|
||||||
|
@ -74,18 +79,54 @@
|
||||||
;; Why is the output socket unbuffered? So that if the client
|
;; Why is the output socket unbuffered? So that if the client
|
||||||
;; closes the connection, we won't lose when we try to close the
|
;; closes the connection, we won't lose when we try to close the
|
||||||
;; socket by trying to flush the output buffer.
|
;; socket by trying to flush the output buffer.
|
||||||
(lambda (sock addr) ; Called once for every connection.
|
(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
|
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
|
||||||
(fork-thread
|
(fork-thread
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-current-input-port
|
(with-current-input-port
|
||||||
(socket:inport sock) ; bind the
|
(socket:inport sock)
|
||||||
(with-current-output-port
|
(with-current-output-port
|
||||||
(socket:outport sock) ; stdio ports, &
|
(socket:outport sock)
|
||||||
(set-port-buffering (current-input-port) bufpol/none)
|
(set-port-buffering (current-input-port) bufpol/none)
|
||||||
(process-toplevel-request sock options)
|
(process-toplevel-request sock host-address options)))
|
||||||
(close-socket sock))) ; do it.
|
(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))))
|
port))))
|
||||||
|
|
||||||
;;; Top-level http request processor
|
;;; Top-level http request processor
|
||||||
|
@ -100,7 +141,7 @@
|
||||||
;;; this code to some other Scheme, you'd really have to sit down and think
|
;;; this code to some other Scheme, you'd really have to sit down and think
|
||||||
;;; about this issue for a minute.
|
;;; 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.
|
;; 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
|
;; 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
|
;; 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.
|
;; We *oughta* map non-http-errors into replies anyway.
|
||||||
(with-fatal-error-handler (lambda (c decline) ; No call to decline
|
(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.
|
(if (http-error? c) ; -- we handle all.
|
||||||
(apply (lambda (reply-code req . args)
|
(apply (lambda (reply-code req . args)
|
||||||
(apply send-http-error-reply
|
(apply send-http-error-reply
|
||||||
reply-code req options
|
reply-code req options
|
||||||
args))
|
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
|
(let ((req (with-fatal-error-handler ; Map syntax errors
|
||||||
(lambda (c decline) ; to http errors.
|
(lambda (c decline) ; to http errors.
|
||||||
|
@ -189,7 +243,8 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(socket-address->internet-address (socket-remote-address sock)))
|
(socket-address->internet-address (socket-remote-address sock)))
|
||||||
(lambda (host-address service-port)
|
(lambda (host-address service-port)
|
||||||
(http-log "~a: ~a~%"
|
(http-log "<~a>~a: ~a~%"
|
||||||
|
(pid)
|
||||||
(format-internet-host-address host-address)
|
(format-internet-host-address host-address)
|
||||||
line))))
|
line))))
|
||||||
|
|
||||||
|
|
15
modules.scm
15
modules.scm
|
@ -282,6 +282,20 @@
|
||||||
httpd-options-server-admin
|
httpd-options-server-admin
|
||||||
httpd-options-simultaneous-requests))
|
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
|
(define-structure httpd-core httpd-core-interface
|
||||||
(open threads locks
|
(open threads locks
|
||||||
thread-fluids ; fork-thread
|
thread-fluids ; fork-thread
|
||||||
|
@ -304,6 +318,7 @@
|
||||||
format-net
|
format-net
|
||||||
sunet-utilities
|
sunet-utilities
|
||||||
httpd-read-options
|
httpd-read-options
|
||||||
|
rate-limit
|
||||||
scheme)
|
scheme)
|
||||||
(files httpd-core))
|
(files httpd-core))
|
||||||
|
|
||||||
|
|
|
@ -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))
|
Loading…
Reference in New Issue