Hi!
Some time ago Xach (Zach) gave me the source to a utility routine he wrote to add 'seen' tracking to a bot of his.
I generalised the code and made library-code of it adding several hooks.
The patch below applies to HEAD as of this moment and adds a generalised version of event tracking. It does not only track 'seen', it adds 'spoke' by default too. Next to that, it implements the general tools to track any event a library-user may want to track.
I'd *love* to hear your comments.
bye,
Erik.
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 6 Jan 2006 21:38:25 -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 6 Jan 2006 21:38:25 -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 6 Jan 2006 21:38:25 -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 6 Jan 2006 21:38:25 -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)) +