Add rate limiting to httpd.
This commit is contained in:
parent
d9fc32433d
commit
9a2be969d5
|
@ -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))))
|
||||
|
||||
|
|
15
modules.scm
15
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))
|
||||
|
||||
|
|
|
@ -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