scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add rate limiting to httpd.

This commit is contained in:
sperber 2002-03-01 08:54:48 +00:00
parent d9fc32433d
commit 9a2be969d5
3 changed files with 145 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
httpd-core.scm
View File

@ -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
View File

@ -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))

58
rate-limit.scm Normal file
View File

@ -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))