[cl-irc-devel] [PATCH] Add 'seen' and 'spoke' support
Erik Huelsmann
e.huelsmann at gmx.net
Fri Jan 6 21:43:26 UTC 2006
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 at gwi.net>
+;;;
+;;; Adapted to be part of cl-irc by Erik Huelsmann <e.huelsmann at 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)
+ , at 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))
+
--
10 GB Mailbox, 100 FreeSMS/Monat http://www.gmx.net/de/go/topmail
+++ GMX - die erste Adresse für Mail, Message, More +++
--
10 GB Mailbox, 100 FreeSMS/Monat http://www.gmx.net/de/go/topmail
+++ GMX - die erste Adresse für Mail, Message, More +++
More information about the cl-irc-devel
mailing list