Ticket #13: tracking.patch3

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  8 Jan 2006 22:25:28 -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        8 Jan 2006 22:25:28 -0000
@@ -129,5 +129,11 @@
              :users-
              :wallops
              :userhost
-             :ison)))
+             :ison
+             ;;; user activity tracking
+             :record-events
+             :recorded-event
+             :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       8 Jan 2006 22:25:28 -0000
@@ -159,7 +159,8 @@
    (users
     :initarg :users
     :accessor users
-    :initform (make-hash-table :test #'equal))))
+    :initform (make-hash-table :test #'equal))
+   (track-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  8 Jan 2006 22:25:28 -0000
@@ -0,0 +1,288 @@
+;;;
+;;; track.lisp
+;;;
+;;; Heavily based on seen.lisp
+;;;     as created on 2004-01-08 by Zach Beane <xach@gwi.net>
+;;;
+;;; Adapted to be part of cl-irc by Erik Huelsmann <e.huelsmann@gmx.net>
+;;;
+;;;
+
+(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 msg-type time &rest rest)
+  (let ((key (list nick msg-type)))
+    (with-open-file (out (msg-db-file db)
+                         :direction :output
+                         :if-exists :append
+                         :if-does-not-exist :create)
+      (apply #'%file-update (append (list out key time) rest)))
+    (incf (msg-db-update-count db))
+    (maybe-compact-db db)
+    (apply #'%table-update (append (list (msg-db-table db) key time) rest))))
+
+(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)))))
+
+
+;; track-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
+
+
+;; Default events to be recorded
+
+(defmethod track-data ((message irc-message))
+  (values :unknown (list command message)))
+
+(defmethod track-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 track-data ((message irc-join-message))
+  (values :joined (list (trailing-argument message))))
+
+(defmethod track-data ((message irc-quit-message))
+  (values :quit (list (trailing-argument message))))
+
+(defmethod track-data ((message irc-part-message))
+  (with-slots-and-args (trailing-argument) (channel)
+      message
+    (values :left (list channel trailing-argument))))
+
+(defmethod track-data ((message irc-nick-message))
+  (with-slots-and-args (source) (new-nick)
+      message
+    (values :nick-changed (list source new-nick))))
+
+(defmethod track-data ((message irc-privmsg-message))
+  (with-slots-and-args (received-time trailing-argument arguments)
+                         (channel)
+                         message
+    (values :privmsg (list trailing-argument channel))))
+
+(defmethod track-data ((message ctcp-action-message))
+  (with-slots-and-args (received-time trailing-argument arguments)
+                         (channel)
+                         message
+    (values :action (list trailing-argument channel))))
+
+;; Most messages have the the source as track-related nick,
+;; but there are exceptions.
+
+(defmethod track-nicks ((message irc-message))
+  (list (source message)))
+
+(defmethod track-nicks ((message irc-kick-message))
+  (destructuring-bind (channel target)
+      (arguments message)
+    (declare (ignore channel))
+    (list target (source message))))
+
+
+
+;; Hook setup
+
+(defun make-track-hook (connection db data-callback nicks-callback)
+  (lambda (message)
+    (let ((time (received-time message))
+          (data (multiple-value-list (funcall data-callback message))))
+      (dolist (nick (mapcar #'(lambda (x)
+                                (normalize-nickname connection x))
+                            (funcall nicks-callback message)))
+        (apply #'update-db
+               (append (list db nick (type-of message) time) data))))))
+
+
+(defvar special-message-names
+  '((:seen irc-kick-message
+           irc-quit-message
+           irc-part-message
+           irc-join-message
+           irc-nick-message)
+    (:spoke irc-privmsg-message
+            ctcp-action-message)))
+
+(defun map-special-messages (messages)
+  (mapcan #'(lambda (x) (if (keywordp x)
+                            ;; copy-list is here because
+                            ;; mapcan modifies its lists
+                            (copy-list (cdr (assoc x special-message-names)))
+                          (list x)))
+          messages))
+
+(defun record-events (connection file
+                                 &key (data #'track-data)
+                                      (nicks #'track-nicks)
+                                      (messages '(:seen :spoke)))
+  "Add hooks to CONNECTION necessary to track event information.
+Uses FILE as the event database.
+
+Returns the database-object used to record events."
+  (let* ((db (make-msg-db :file file))
+         (fun (make-track-hook connection db data nicks)))
+    (setf (slot-value connection 'track-db) db)
+    (dolist (class (map-special-messages messages))
+      (add-hook connection class fun))
+    db))
+
+(defmethod recorded-event ((connection connection) nick
+                           &optional (messages '(:seen :spoke)))
+  (values-list
+   (reduce #'(lambda (&optional x y)
+               (cond
+                ((and x y)
+                 ;; select latest (newest) event
+                 (if (> (first x) (first y)) x y))
+                (x x)
+                (y y)))
+           (mapcar #'(lambda (x)
+                       (gethash (list nick x)
+                                (msg-db-table
+                                 (slot-value connection 'track-db))))
+                   (map-special-messages messages)))))
+
+(defmethod seen ((connection connection) nick)
+  "Returns (values time event-type msg-data ...)"
+  (recorded-event connection nick '(:seen)))
+
+(defmethod spoke ((connection connection) nick)
+  "Returns (values time event-type msg-data ...)"
+  (recorded-event connection nick '(:spoke)))
+
+
+;; Formatting of default recorded events
+
+(defmethod fmt-track (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-track (stream (action (eql :joined)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (channel)
+      arguments
+    (format stream "joining ~A" channel)))
+
+(defmethod fmt-track (stream (action (eql :left)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (channel text)
+      arguments
+  (format stream "leaving ~A~@[ (~A)~]" channel text)))
+
+(defmethod fmt-track (stream (action (eql :quit)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (text)
+      arguments
+    (format stream "leaving irc~@[ (~A)~]" text)))
+
+(defmethod fmt-track (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)))
+
+(defmethod fmt-track (stream (action (eql :privmsg)) arguments)
+  (declare (ignore action))
+  (destructuring-bind
+      (text channel)
+      arguments
+    (format stream "'~A' in ~A" text channel)))
+
+
+(defun format-track-data (stream action arguments)
+  (fmt-track stream action arguments))
+