Summer 2014 update.

* apache.txr: restructuring of matching rules. Some new intruders listed.
  Now also checks HTTP response code to detect accesses to nonexistent pages.
  Bugfix: was not calling do-expiry.

* txrban.txr: added code at top of @(do) to easily turn off daemonization
  and redirect logging to stdout for debugging.
  (*extrainfo*): New global hash.
  (report): New optional argument to pass extra info.
  (get-info): Function to retrieve the list of extra info for an IP address.
  (clear): New function to unban an IP and completely clear its access history.
  (ban): Use new sh function instead of open-command. Use new backquote
  operator ^ instead of '.
  (process-histories): When the recent access history is empty, delete
  it from *access-hist* rather than keeping an empty list there.
  Also delete the *extrainfo* when this happens.
  (do-expiry): Use unban function for unbanning.
  (unban): New function.

* utils.txr (m): New pattern function for parsing month name.
  (self): New variable to hold the script's own name.
  (debug): Send output to *stdlog* instead of *stdout*, so
  that we now have syslog logging.

* exim.txr: New file.

* ssh.txr: New file.

* startup.sh: New file.

6 files changed, 136 insertions, 30 deletions

diff --git a/apache.txr b/apache.txr
index bb873d4..6793a78 100644
--- a/apache.txr
+++ b/apache.txr
@@ -1,23 +1,25 @@
 @(load "txrban")
 @(next @(open-tail "/var/log/apache2/www.kylheku.com.log" "r" nil))
-@#(next "/var/log/apache2/www.kylheku.com.log")
 @(repeat)
-@  (block badguys)
-@    (all)
-@ip - - [@(n day)/@month/@(n year):@(n hour):@(n min):@(n sec) @nil] "@method @uri @proto/@ver" @err @bytes "@ref" "@agent"
-@    (and)
-@      (cases)
-@        (require (search-regex agent #/Googlebot|bingbot|baidu/))
-@        (fail badguys)
-@      (or)
-@        (require (search-regex agent #/[Bb][Oo][Tt]|[Ss]pider|[Cc]rawler|[Yy]andex/))
-@        (bind points 9)
-@      (or)
-@        (bind points 0)
-@      (end)
+@  (all)
+@ip - - [@(n day)/@(m month)/@(n year):@(n hour):@(n min):@(n sec) @nil] "@method @uri @proto/@ver" @err @bytes "@ref" "@agent"
+@  (and)
+@    (cases)
+@      (require (search-regex agent #/Googlebot|bingbot|baidu/))
+@      (bind points nil)
+@    (or)
+@      (require (search-regex agent #/Ezoom|[Bb][Oo][Tt]|[Ss]pider|[Cc]rawler|[Yy]andex|coccoc/))
+@      (bind points 9)
+@    (or)
+@      (require (not (memqual err '("200" "301" "304"))))
+@      (bind points 1)
+@    (or)
+@      (bind points 0)
 @    (end)
-@    (do
-       (let ((time (make-time year (month-num month) day hour min sec :auto)))
-         (report ip time points)))
 @  (end)
+@  (do
+     (let ((time (make-time year month day hour min sec :auto)))
+       (if points
+         (report ip time points)
+         (do-expiry time))))
 @(end)
diff --git a/exim.txr b/exim.txr
new file mode 100644
index 0000000..46d5cf0
--- /dev/null
+++ b/exim.txr
@@ -0,0 +1,37 @@
+@(load "txrban")
+@(next @(open-tail "/var/log/exim4/rejectlog" "r" nil))
+@(repeat)
+@  (block continue)
+@    (all)
+@(n year)-@(n month)-@(n day) @(n hour):@(n min):@(n sec) @(skip)
+@    (and)
+@      (cases)
+@nil @nil H=@host [@ip] F=<@sender@@@domain> rejected RCPT <@recip@@@rdomain>: @rejreason
+@        (next :string rejreason)
+@        (cases)
+@(skip)(@ip) is listed@(skip)
+@          (bind points 0)
+@        (or)
+host lookup failed@(skip)
+@          (bind points 10)
+@        (or)
+@          (bind points 6)
+@        (end)
+@      (or)
+@nil @nil SMTP protocol synchronization error @(skip)[@ip]@(skip)
+@        (bind points 10)
+@      (or)
+@nil @nil SMTP call from@(skip)[@ip] dropped: too many nonmail@(skip)
+@        (bind points 10)
+@      (or)
+@nil @nil cram_md5_server authenticator failed @(skip)[@ip]@(skip)
+@        (bind points 10)
+@      (or)
+@        (accept continue)
+@      (end)
+@      (do
+         (let ((time (make-time year month day hour min sec :auto)))
+           (report ip time points)))
+@    (end)
+@  (end)
+@(end)
diff --git a/ssh.txr b/ssh.txr
new file mode 100644
index 0000000..13cd77b
--- /dev/null
+++ b/ssh.txr
@@ -0,0 +1,26 @@
+@(load "txrban")
+@(set *short-period* 15)
+@(set *short-limit* 15)
+@(set *short-ban* @(* 24 3600))
+@(set *long-period* 300)
+@(set *long-limit* 10)
+@(set *long-ban* @(* 24 3600))
+@(next @(open-tail "/var/log/auth.log" "r" nil))
+@(repeat)
+@  (all)
+@(m month) @(n day) @(n year) @(n hour):@(n min):@(n sec) @(skip)
+@    (bind time @(make-time year month day hour min sec :auto))
+@  (and)
+@    (cases)
+@nil @nil @nil @nil localhost sshd[@nil]: Failed password for @user from @ip port @(skip)
+@      (do
+         (let ((users (get-info ip))
+               (level 0))
+           (if (> (length users) 3)
+             (set level 9))
+           (report ip time level user)))
+@    (or)
+@      (do (do-expiry time))
+@    (end)
+@  (end)
+@(end)
diff --git a/startup.sh b/startup.sh
new file mode 100755
index 0000000..a1c7bb8
--- /dev/null
+++ b/startup.sh
@@ -0,0 +1,7 @@
+#!/bin/sh
+PATH=$PATH:/usr/local/bin
+MYDIR=$(dirname "$0")
+
+txr $MYDIR/apache.txr
+txr $MYDIR/exim.txr
+txr $MYDIR/ssh.txr
diff --git a/txrban.txr b/txrban.txr
index bc1ee77..98f2a5c 100644
--- a/txrban.txr
+++ b/txrban.txr
@@ -1,9 +1,15 @@
 @(load "config")
 @(load "utils")
 @(do
+   (cond
+     (t (daemon nil nil)
+        (openlog `txrban-@self` log-pid log-authpriv))
+     (nil (set *stdlog* *stdout*)))
+
    (defvar *access-hist* (hash :equal-based))
    (defvar *points* (hash :equal-based))
    (defvar *banned* (hash :equal-based))
+   (defvar *extrainfo* (hash :equal-based))
 
    (defvar *off* "") ;; set this to "#" to comment out commands
 
@@ -13,8 +19,10 @@
    ;;; 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)
+   (defun report (ip time level : extrainfo)
      (push time [*access-hist* ip])
+     (if (and extrainfo (not (memqual extrainfo [*extrainfo* ip])))
+       (push extrainfo [*extrainfo* ip]))
      (if (> level 0)
        (let* ((points (inc [*points* ip 0] level))
               (severity (- points 5)))
@@ -25,6 +33,15 @@
      (process-histories time)
      (do-expiry time))
 
+   (defun get-info (ip)
+     [*extrainfo* ip])
+
+   (defun clear (ip)
+     (del [*access-hist* ip])
+     (del [*extrainfo* ip])
+     (del [*points* ip])
+     (unban ip))
+
    (defun ban-duration (severity)
      [*ban-duration* (min (- (length *ban-duration*) 1) severity)])
 
@@ -34,15 +51,14 @@
             (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)))
+          (sh `@{*off*}iptables -I INPUT 1 -s @ip -i @{*iface*} -j DROP`)
+          (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))))))
+            (set [*banned* ip] ^(,new-until ,*time))))))
 
    (defun process-histories (time)
      (let ((long-range (- time *long-period*))
@@ -51,7 +67,11 @@
          (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 nacc
+             (set [*access-hist* ip] nacc)
+             (progn
+               (del [*access-hist* ip])
+               (del [*extrainfo* ip])))
            (if (> long-count *long-limit*)
              (ban ip time *long-ban*))
              (if (> short-count *short-limit*)
@@ -60,7 +80,9 @@
    (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]))))))
+         (unban ip))))
+
+   (defun unban (ip)
+     (sh `@{*off*}iptables -D INPUT -s @ip -i @{*iface*} -j DROP`)
+     (debug "unbanned ~a\n" ip)
+     (del [*banned* ip])))
diff --git a/utils.txr b/utils.txr
index ca8e256..a572aeb 100644
--- a/utils.txr
+++ b/utils.txr
@@ -1,8 +1,20 @@
 @(define n (a))@(local n)@{n /\d+/}@(bind a @(int-str n))@(end)
+@(define m (a))@(local m)@{m /\w+/}@(bind a @(month-num m))@(end)
+@#
+@(next :string @(identity *self-path*))
+@(some)
+@*nil/@self.@nil
+@(or)
+@*nil/@self
+@(or)
+@self.@nil
+@(or)
+@self
+@(end)
 @#
 @(do
    (defun debug (arg . args)
-     [apply format '(t ,arg ,*args)])
+     [apply format ^(, *stdlog* ,arg ,*args)])
 
    (defun hrtime (time)
      (cond