Ticket #13: tracking.patch

TODO

@@ -2 +2 @@
   - Add DCC
 
     - I would really like usocket first
+    - In the process add configuration options for automatically accepting
+      DCC connections (both :send and :chat types)
 
   - If a message (as in PRIVMSG) is longer than 512 characters
   (including carriage return and linefeed) we should probably split

cl-irc.asd

@@ -39 +39 @@
                  (:file "command"
                         :depends-on ("protocol"))
                  (:file "event"
+                        :depends-on ("command"))
+                 (:file "track"
                         :depends-on ("command"))))

package.lisp

@@ -129 +129 @@
              :users-
              :wallops
              :userhost
-             :ison)))
+             :ison
+             ;;; user activity tracking
+             :track-seen
+             :track-spoke
+             :seen
+             :spoke
+             )))
 

protocol.lisp

@@ -159 +159 @@
    (users
     :initarg :users
     :accessor users
-    :initform (make-hash-table :test #'equal))))
+    :initform (make-hash-table :test #'equal))
+   (seen-db)
+   (spoke-db)))
 
 (defmethod print-object ((object connection) stream)
   "Print the object for the Lisp reader."

new file track.lisp

@@ +1 @@
+;;;
+;;; seen.lisp
+;;;
+;;; Created: 2004-01-08 by Zach Beane <xach@gwi.net>
+;;;
+;;; Adapted to be part of cl-irc by Erik Huelsmann <e.huelsmann@gmx.net>
+;;;
+;;; Track the last time a nick was seen doing certain IRC
+;;; stuff. Can be publicly queried with:
+;;;
+;;;   botname, seen johndoe?
+;;;
+;;; or
+;;;
+;;;   /msg botname seen johndoe?
+;;;
+;;;
+;;; To add it to your bot, do something like:
+;;;
+;;;   (irc-seen:initialize connection "seen-db.sexp")
+;;;
+
+(in-package :irc)
+
+
+(defclass msg-db ()
+  ((table :reader msg-db-table
+          :initform (make-hash-table :test 'equalp)
+          :documentation "A hash table mapping IRC nicknames to
+          their seen data.")
+   (file :reader msg-db-file
+         :initarg :file
+         :documentation "The file to which seen data will be
+         saved and updated.")
+   (compact-threshold :accessor msg-db-compact-threshold
+                      :initarg :compact-threshold
+                      :initform 10000
+                      :documentation "How many updates to write
+                      to the data file before compacting it.")
+   (update-count :accessor msg-db-update-count
+                 :initform 0)))
+
+(defun %file-update (stream key &rest args)
+  (let ((*print-pretty* nil)
+        (*print-readably* t))
+    (print (cons key args) stream)))
+
+(defun %table-update (table key &rest args)
+  (setf (gethash key table) args))
+
+(defmethod update-db ((db msg-db)
+                      nick time message &optional channel)
+  (with-open-file (out (msg-db-file db)
+                       :direction :output
+                       :if-exists :append
+                       :if-does-not-exist :create)
+    (%file-update out nick time message channel)
+  (incf (msg-db-update-count db))
+  (maybe-compact-db db)
+  (%table-update (msg-db-table db)
+                 nick time message channel)))
+
+(defmethod save-db ((db msg-db))
+  (with-open-file (out (msg-db-file db)
+                       :direction :output
+                       :if-exists :supersede
+                       :if-does-not-exist :create)
+    (maphash #'(lambda (key val)
+                 (apply #'%file-update out key val))
+             (msg-db-table db))))
+
+(defmethod compact-db ((db msg-db))
+  (save-db db)
+  (setf (msg-db-update-count db) 0))
+
+(defmethod maybe-compact-db ((db msg-db))
+  (when (> (msg-db-update-count db)
+           (msg-db-compact-threshold db))
+    (compact-db db)))
+
+(defmethod load-db ((db msg-db))
+  (with-open-file (in (msg-db-file db)
+                      :direction :input
+                      :if-does-not-exist :create)
+    (loop for item = (read in nil nil)
+          while item
+          do
+          (destructuring-bind
+              (nick &rest rest)
+              item
+            (apply #'%table-update (append (list (msg-db-table db) nick)
+                                           rest))))))
+
+
+(defun make-msg-db (&key file (compact-threshold 10000))
+  (let ((db (make-instance 'msg-db
+                           :file file
+                           :compact-threshold compact-threshold)))
+    (load-db db)
+    (compact-db db)
+    db))
+
+
 
+;;; Producing pretty messages for various events
+
+(defmacro with-slots-and-args (slots args message &body body)
+  "Evaluate BODY with the slots of the MESSAGE bound to the
+  symbols of SLOTS, and the arguments of the message
+  destructuring-bind'ed to ARGS."
+  (let ((irc-message (gensym)))
+    `(let ((,irc-message ,message))
+       (with-slots ,slots ,irc-message
+         (destructuring-bind ,args (arguments ,irc-message)
+           ,@body)))))
+
+
+
+(defmethod seen-message ((message irc-message))
+  (format nil "something to do with ~A" (command message)))
+
+(defmethod seen-message ((message irc-kick-message))
+  (with-slots-and-args (source trailing-argument) (channel target)
+      message
+    (declare (ignore target))
+    (format nil "being kicked out of ~A by ~A ~@[(~A)~]"
+            channel source trailing-argument)))
+
+(defmethod seen-message ((message irc-join-message))
+  (format nil "joining ~A" (trailing-argument message)))
+
+(defmethod seen-message ((message irc-quit-message))
+  (format nil "quitting irc~@[ saying ~A~]" (trailing-argument message)))
+
+(defmethod seen-message ((message irc-part-message))
+  (with-slots-and-args (trailing-argument) (channel)
+      message
+    (format nil "leaving ~A~@[ saying ~A~]" channel trailing-argument)))
+
+(defmethod seen-message ((message irc-nick-message))
+  (with-slots-and-args (source) (new-nick)
+      message
+    (format nil "changing his nick from ~A to ~A" source new-nick)))
+
+;; Most messages have the seen-related nick as the source, but
+;; there are exceptions.
+
+(defmethod track-nick ((message irc-message))
+  (source message))
+
+(defmethod track-nick ((message irc-kick-message))
+  (destructuring-bind (channel target)
+      (arguments message)
+    target))
+
+
+
 
+;; Hook setup
+
+(defun make-seen-nick-hook (db)
+  ;; Triggers two updates
+  (lambda (message)
+    (let ((time (received-time message))
+          (seen-message (seen-message message)))
+      (destructuring-bind (new-nick)
+          (arguments message)
+        (update-db db (track-nick message) time seen-message)
+        (update-db db new-nick time seen-message)))))
+
+(defun make-spoke-hook (db)
+  (lambda (message)
+    (update-db db
+               (track-nick message)
+               (received-time message)
+               (trailing-argument message)
+               (first (arguments message)))))
+
+(defun track-seen (connection file)
+  "Add hooks to CONNECTION necessary to track `seen' information
+and respond to user queries. Uses FILE as the `seen' database.
+
+Returns the database-object used to track seen messages."
+  (let* ((db (make-msg-db :file file))
+         (fun (lambda (irc-message)
+                (update-db db
+                           (track-nick irc-message)
+                           (received-time irc-message)
+                           (seen-message irc-message)))))
+    (setf (slot-value connection 'seen-db) db)
+    (dolist (class '(irc-kick-message
+                     irc-quit-message
+                     irc-part-message
+                     irc-join-message))
+      (add-hook connection class fun))
+    (add-hook connection 'irc-nick-message
+                  (make-seen-nick-hook db))))
+
+(defun track-spoke (connection file)
+  (let* ((db (make-msg-db :file file))
+         (fun (make-spoke-hook db)))
+    (setf (slot-value connection 'spoke-db) db)
+    (dolist (class '(irc-privmsg-message
+                     ctcp-action-message))
+      (add-hook connection class fun))))
+
+(defmethod seen ((connection connection) nick)
+  "Returns (values time msg)"
+  (values-list (gethash nick (msg-db-table (slot-value connection 'seen-db)))))
+
+(defmethod spoke ((connection connection) nick)
+  "Returns (values time msg channel)"