diff options
Diffstat (limited to 'haunt')
| -rw-r--r-- | haunt/api.scm | 24 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/rate-limiter.scm | 77 |
2 files changed, 90 insertions, 11 deletions
diff --git a/haunt/api.scm b/haunt/api.scm index 1d275f8..b1db096 100644 --- a/haunt/api.scm +++ b/haunt/api.scm @@ -21,6 +21,7 @@ (jakob dynamic capabilities gallery) (jakob dynamic capabilities rsvp) (jakob dynamic logging) + (jakob dynamic rate-limiter) (srfi srfi-1) (web request) (web response) @@ -39,17 +40,18 @@ (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For)) (args (uri-query (request-uri request)))) (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip))) - ((match (cons (request-method request) endpoint) - (('GET "comment-form" _) get-comment-form) - ('(GET "challenge" "proof-of-work") make-pow-challenge!) - ('(GET "challenge" "captcha") make-captcha-challenge!) - ;; ('(GET "comments") get-comments) - (('POST "comment") put-comment) - (('GET "gallery") get-gallery) - (('GET "gallery" "image") get-image) - (('GET "rsvp" "event-info") get-event-info) - (('POST "rsvp") post-event-rsvp) - (_ (lambda (. args) (not-found request)))) + ((rate-limit-wrap + (match (cons (request-method request) endpoint) + (('GET "comment-form" _) get-comment-form) + ('(GET "challenge" "proof-of-work") make-pow-challenge!) + ('(GET "challenge" "captcha") make-captcha-challenge!) + ;; ('(GET "comments") get-comments) + (('POST "comment") put-comment) + (('GET "gallery") get-gallery) + (('GET "gallery" "image") get-image) + (('GET "rsvp" "event-info") get-event-info) + (('POST "rsvp") post-event-rsvp) + (_ (lambda (. args) (not-found request))))) request body)) (define (main-request-handler request body) diff --git a/haunt/jakob/dynamic/rate-limiter.scm b/haunt/jakob/dynamic/rate-limiter.scm new file mode 100644 index 0000000..bd39d07 --- /dev/null +++ b/haunt/jakob/dynamic/rate-limiter.scm @@ -0,0 +1,77 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic rate-limiter) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (web request) + #:use-module (web response) + #:export (rate-limit-wrap)) + +(define-record-type <requester-state> + (make-requester-state time request-bins) + requester-state? + (time requester-state-time) + (request-bins requester-state-bins)) + +(define active-rate-limits (make-hash-table)) + +(define (rate-limit-handler-stub request body) + (values (build-response #:code 429) + (scm->json-string + `((success . #f) + (error . "Your IP address is currently being rate-limited."))))) + +(define (increment-key! hash-table key) + (let ((new-value (if (hash-ref hash-table key) + (+ 1 (hash-ref hash-table key)) + 1))) + (hash-set! hash-table key new-value))) + +(define (rate-limit-for-endpoint name) 32) + +(define (rate-limit-wrap proc) + (lambda (request body) + (unless (assoc-ref (request-headers request) 'x-forwarded-for) + (raise (condition (make-message-condition "X-Forwarded-For header not provided")))) + (let ((endpoint-name (procedure-name proc)) + (requester (chain (assoc-ref (request-headers request) 'x-forwarded-for) + (string-split _ #\,) + (first _)))) + (unless (hash-ref active-rate-limits requester) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (increment-key! (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + ;; TODO: The `when' body is copy/pasted from above. I think this condition + ;; (time-based expiry) could be refactored. + (when (>= (current-time) + (+ (* 60 60) (requester-state-time (hash-ref active-rate-limits requester)))) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (if (and (> (hash-ref (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + (rate-limit-for-endpoint endpoint-name))) + (values (build-response #:code 429) + (scm->json-string + `((success . #f) + (error . "Your IP address is currently being rate-limited.")))) + (proc request body))))) |