Ticket #13: tracking.patch2

? dist.sh
? msg
? tracking.patch
? tracking.patch2
? working-track.lisp
? doc/tracking-considerations
Index: TODO
===================================================================
RCS file: /project/cl-irc/cvsroot/cl-irc/TODO,v
retrieving revision 1.2
diff -u -r1.2 TODO
--- TODO        20 Mar 2005 16:55:36 -0000      1.2
+++ TODO        4 Jan 2006 22:34:37 -0000
@@ -2,6 +2,8 @@
   - 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
Index: cl-irc.asd
===================================================================
RCS file: /project/cl-irc/cvsroot/cl-irc/cl-irc.asd,v
retrieving revision 1.2
diff -u -r1.2 cl-irc.asd
--- cl-irc.asd  29 Mar 2004 19:07:54 -0000      1.2
+++ cl-irc.asd  4 Jan 2006 22:34:37 -0000
@@ -39,4 +39,6 @@
                  (:file "command"
                         :depends-on ("protocol"))
                  (:file "event"
+                        :depends-on ("command"))
+                 (:file "track"
                         :depends-on ("command"))))
Index: package.lisp
===================================================================
RCS file: /project/cl-irc/cvsroot/cl-irc/package.lisp,v
retrieving revision 1.8
diff -u -r1.8 package.lisp
--- package.lisp        15 Apr 2005 16:01:22 -0000      1.8
+++ package.lisp        4 Jan 2006 22:34:37 -0000
@@ -129,5 +129,11 @@
              :users-
              :wallops
              :userhost
-             :ison)))
+             :ison
+             ;;; user activity tracking
+             :track-seen
+             :track-spoke
+             :seen
+             :spoke
+             )))
 
Index: protocol.lisp
===================================================================
RCS file: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v
retrieving revision 1.25
diff -u -r1.25 protocol.lisp
--- protocol.lisp       25 Sep 2005 14:55:02 -0000      1.25
+++ protocol.lisp       4 Jan 2006 22:34:37 -0000
@@ -159,7 +159,9 @@
    (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."
Index: track.lisp
===================================================================
RCS file: track.lisp
diff -N track.lisp
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ track.lisp  4 Jan 2006 22:34:37 -0000
@@ -0,0 +1,267 @@
+;;;
+;;; 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)))))
+
+
+;; seen-data returns (values):
+
+;;  * a keyword designating the registered event, one of:
+;;    :joined
+;;    :left
+;;    :quit
+;;    :kicked
+;;    :nick-changed
+;;    :unknown
+;;  * a list of arguments for the given event
+
+
+(defmethod seen-data ((message irc-message))
+  (values :unknown (list command message)))
+
+(defmethod seen-data ((message irc-kick-message))
+  (with-slots-and-args (source trailing-argument) (channel target)
+      message
+    (declare (ignore target))
+    (values :kicked (list channel source trailing-argument))))
+
+(defmethod seen-data ((message irc-join-message))
+  (values :joined (list (trailing-argument message))))
+
+(defmethod seen-data ((message irc-quit-message))
+  (values :quit (list (trailing-argument message))))
+
+(defmethod seen-data ((message irc-part-message))
+  (with-slots-and-args (trailing-argument) (channel)
+      message
+    (values :left (list channel trailing-argument))))
+
+(defmethod seen-data ((message irc-nick-message))
+  (with-slots-and-args (source) (new-nick)
+      message
+    (values :nick-changed (list 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-hook (db)
+  (lambda (message)
+    (let ((seen-data (multiple-value-list (seen-data message))))
+      (apply #'update-db (append (list db
+                                       (track-nick message)
+                                       (received-time message))
+                                 seen-data)))))
+
+(defun make-seen-nick-hook (db)
+  (lambda (message)
+    (let ((time (received-time message))
+          (new-nick (first (arguments message)))
+          (seen-data (multiple-value-list (seen-data message))))
+      (dolist (nick (list (track-nick message) new-nick))
+        (apply #'update-db (append (list db nick time) seen-data))))))
+
+(defun make-spoke-hook (db)
+  (lambda (message)
+    (with-slots-and-args (received-time trailing-argument arguments)
+                         (channel)
+                         message
+       (update-db db (track-nick message)
+                  received-time trailing-argument channel))))
+
+(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 (make-seen-hook db)))
+    (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 event-type msg-data ...)"
+  (values-list (gethash nick (msg-db-table (slot-value connection 'seen-db)))))
+
+
+(defmethod fmt-seen (stream (action (eql :kicked)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (channel oper text)
+      arguments
+    (format stream "being kicked out of ~A by ~A~@[ (~A)~]"
+            channel oper text)))
+
+(defmethod fmt-seen (stream (action (eql :joined)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (channel)
+      arguments
+    (format stream "joining ~A" channel)))
+
+(defmethod fmt-seen (stream (action (eql :left)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (channel text)
+      arguments
+  (format stream "leaving ~A~@[ (~A)~]" channel text)))
+
+(defmethod fmt-seen (stream (action (eql :quit)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (text)
+      arguments
+    (format stream "leaving irc~@[ (~A)~]" text)))
+
+(defmethod fmt-seen (stream (action (eql :nick-changed)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (from-nick to-nick)
+      arguments
+    (format stream "changing his nick from ~A to ~A" from-nick to-nick)))
+
+
+
+(defun format-seen-data (stream action arguments)
+  (fmt-seen stream action arguments))
+
+
+(defmethod spoke ((connection connection) nick)
+  "Returns (values time msg channel)"
+  (values-list (gethash nick
+                        (msg-db-table (slot-value connection 'spoke-db)))))