Implemented point system for banning with timeout scale based on

severity.
Implemented banning based on excessive activity.
Utility functions split off into utils.txr.

4 files changed, 91 insertions, 36 deletions

diff --git a/apache.txr b/apache.txr
index 12d6a9f..bb873d4 100644
--- a/apache.txr
+++ b/apache.txr
@@ -11,11 +11,13 @@
 @        (fail badguys)
 @      (or)
 @        (require (search-regex agent #/[Bb][Oo][Tt]|[Ss]pider|[Cc]rawler|[Yy]andex/))
+@        (bind points 9)
+@      (or)
+@        (bind points 0)
 @      (end)
 @    (end)
 @    (do
        (let ((time (make-time year (month-num month) day hour min sec :auto)))
-         (ban ip time 86400)
-         (expire time)))
+         (report ip time points)))
 @  (end)
 @(end)
diff --git a/sample-config.txr b/sample-config.txr
index 73b05a5..28a82fa 100644
--- a/sample-config.txr
+++ b/sample-config.txr
@@ -1,2 +1,9 @@
-@(do
-   (defvar *iface* "eth0"))
+@(bind *iface* "eth0")
+@(bind *short-period* 30)
+@(bind *short-limit* 600)
+@(bind *short-ban* 180)
+@(bind *long-period* 900)
+@(bind *long-limit* 1800)
+@(bind *long-ban* 3600)
+@(bind *ban-duration*
+       @(list 300 900 3600 (* 6 3600) (* 24 3600) (* 7 24 3600)))
diff --git a/txrban.txr b/txrban.txr
index 89a070f..bc1ee77 100644
--- a/txrban.txr
+++ b/txrban.txr
@@ -1,47 +1,66 @@
 @(load "config")
+@(load "utils")
 @(do
+   (defvar *access-hist* (hash :equal-based))
+   (defvar *points* (hash :equal-based))
    (defvar *banned* (hash :equal-based))
 
    (defvar *off* "") ;; set this to "#" to comment out commands
 
-   (defun debug (arg . args)
-     [apply format '(t ,arg ,*args)])
+   ;;; Report activity of an ip address, for a given time
+   ;;; Levels are 0 through 5. 0 is normal access: client isn't
+   ;;; doing anything wrong, but should be monitored for excessive activity.
+   ;;; Any other level is points which are accumulated.
+   ;;; 5 points lead to a ban, whose severity depends on how many
+   ;;; points in excess of 5 there are.
+   (defun report (ip time level)
+     (push time [*access-hist* ip])
+     (if (> level 0)
+       (let* ((points (inc [*points* ip 0] level))
+              (severity (- points 5)))
+         (if (>= severity 0)
+           (progn
+             (del [*points* ip])
+             (ban ip time (ban-duration severity))))))
+     (process-histories time)
+     (do-expiry time))
 
-   (defun hrtime (time)
-     (cond
-       ((< time 60)
-        (format nil "~ss" time))
-       ((< time 3600)
-        (format nil "~s.~sm" (trunc time 60)
-                (trunc (* (mod time 60) 10) 60)))
-       ((< time 86400)
-        (format nil "~s.~sh"
-                (trunc time 3600)
-                (trunc (* (mod time 3600) 10) 3600)))
-       (t
-        (format nil "~s.~sd"
-                (trunc time 86400)
-                (trunc (* (mod time 86400) 10) 86400)))))
+   (defun ban-duration (severity)
+     [*ban-duration* (min (- (length *ban-duration*) 1) severity)])
 
    (defun ban (ip time howlong)
-     (if (not [*banned* ip])
-       (let ((pipe (open-command `@{*off*}iptables -I INPUT 1 -s @ip -i @{*iface*} -j DROP` "r")))
-         (close-stream pipe)
-         (debug "banned ~a for ~a starting on ~a\n" ip
-                (hrtime howlong) (time-string-local time "%c"))
-         (set [*banned* ip] '(,(+ time howlong) ,*time)))))
+     (let* ((banned [*banned* ip])
+            (until (car banned))
+            (new-until (+ time howlong)))
+       (cond
+         ((not banned)
+          (let ((pipe (open-command `@{*off*}iptables -I INPUT 1 -s @ip -i @{*iface*} -j DROP` "r")))
+            (close-stream pipe)
+            (debug "banned ~a for ~a starting on ~a\n" ip
+                   (hrtime howlong) (time-string-local time "%c")))
+          (set [*banned* ip] '(,new-until ,*time)))
+         ((> new-until until)
+            (debug "extending ban on ~a for ~a starting on ~a\n" ip
+                   (hrtime howlong) (time-string-local time "%c"))
+            (set [*banned* ip] '(,new-until ,*time))))))
 
-   (defun expire (now-time)
+   (defun process-histories (time)
+     (let ((long-range (- time *long-period*))
+           (short-range (- time *short-period*)))
+       (dohash (ip acc *access-hist*)
+         (let* ((nacc (remove-if (op < @1 long-range) acc))
+                (long-count (length nacc))
+                (short-count (count-if (op >= @1 short-range) nacc)))
+           (set [*access-hist* ip] nacc)
+           (if (> long-count *long-limit*)
+             (ban ip time *long-ban*))
+             (if (> short-count *short-limit*)
+               (ban ip time *short-ban*))))))
+
+   (defun do-expiry (now-time)
      (dohash (ip timeinfo *banned*)
        (if (<= (car timeinfo) now-time)
          (let ((pipe (open-command `@{*off*}iptables -D INPUT -s @ip -i @{*iface*} -j DROP` "r")))
            (close-stream pipe)
            (debug "unbanned ~a\n" ip)
-           (del [*banned* ip])))))
-  
-   (defun month-num (month)
-     (cdr (assoc (downcase-str month)
-                 '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4)
-                   ("may" . 5) ("jun" . 6) ("jul" . 7) ("aug" . 8)
-                   ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12))))))
-@(define n (a))@(local n)@{n /\d+/}@(bind a @(int-str n))@(end)
+           (del [*banned* ip]))))))
diff --git a/utils.txr b/utils.txr
new file mode 100644
index 0000000..ca8e256
--- /dev/null
+++ b/utils.txr
@@ -0,0 +1,27 @@
+@(define n (a))@(local n)@{n /\d+/}@(bind a @(int-str n))@(end)
+@#
+@(do
+   (defun debug (arg . args)
+     [apply format '(t ,arg ,*args)])
+
+   (defun hrtime (time)
+     (cond
+       ((< time 60)
+        (format nil "~ss" time))
+       ((< time 3600)
+        (format nil "~s.~sm" (trunc time 60)
+                (trunc (* (mod time 60) 10) 60)))
+       ((< time 86400)
+        (format nil "~s.~sh"
+                (trunc time 3600)
+                (trunc (* (mod time 3600) 10) 3600)))
+       (t
+        (format nil "~s.~sd"
+                (trunc time 86400)
+                (trunc (* (mod time 86400) 10) 86400)))))
+  
+   (defun month-num (month)
+     (cdr (assoc (downcase-str month)
+                 '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4)
+                   ("may" . 5) ("jun" . 6) ("jul" . 7) ("aug" . 8)
+                   ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12))))))