[dynamic] Initial rate limiter

1 files changed, 77 insertions, 0 deletions

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