logger.lisp

   1 ;;;;  -*- Mode: Lisp -*-
   2 ;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $
   3 ;;;;
   4 ;;;; Purpose: A IRC logging bot
   5 ;;;; Author:  Kevin Rosenberg
   6
   7 (in-package irc-logger)
   8
   9 (defclass channel ()
  10   ((name :initarg :name :reader name
  11          :documentation "Name of channel.")
  12    (streams :initarg :streams :reader streams
  13             :documentation "List of output streams.")
  14    (output-root :initarg :output-root :reader output-root)
  15    (current-output-names :initarg :current-output-names :accessor current-output-names)))
  16
  17
  18 (defclass logger ()
  19   ((connection :initarg :connection :reader connection
  20                :documentation "IRC connection object.")
  21    (nick :initarg :nick :reader nickname
  22          :documentation "Nickname of the bot.")
  23    (server :initarg :server :reader server
  24            :documentation "Connected IRC server.")
  25    (channels :initarg :channels :reader channels
  26              :documentation "List of channels.")
  27    (user-output :initarg :user-output :reader user-output
  28                 :documentation
  29                 "Output parameter from user, maybe stream or pathname.")
  30    (unichannel :initarg :unichannel :reader unichannel :type boolean
  31                :documentation "T if user-output is directory for individual channel output.")
  32    (formats :initarg :formats :reader formats
  33                   :documentation
  34                   "A list of output formats.")))
  35
  36 (defvar *loggers* nil "List of active loggers.")
  37
  38 (defparameter *user-address-scanner*
  39   (create-scanner
  40    '(:sequence #\!
  41      (:register
  42       (:greedy-repetition 1 nil :non-whitespace-char-class)))
  43    :case-insensitive-mode t))
  44
  45 (defun find-logger-with-nick (nick)
  46   (find nick (the list *loggers*) :test #'string-equal :key #'nickname))
  47
  48 (defun make-output-name (name year month day)
  49     (format nil "~A-~4,'0D.~2,'0D.~2,'0D"
  50             (string-left-trim '(#\#) name) year month day))
  51
  52 (defun make-output-name-utime (name utime)
  53   (multiple-value-bind
  54         (second minute hour day-of-month month year day-of-week daylight-p zone)
  55       (decode-universal-time utime)
  56     (declare (ignore second minute hour day-of-week daylight-p zone))
  57     (make-output-name name year month day-of-month)))
  58
  59 (defgeneric write-file-header (format channel-name stream))
  60
  61 (defmethod write-file-header ((format t) channel-name stream)
  62   (declare (ignore format channel-name stream))
  63   )
  64
  65 (defgeneric write-file-footer (format channel-name stream))
  66
  67 (defmethod write-file-footer ((format t) channel-name stream)
  68   (declare (ignore format channel-name stream))
  69   )
  70
  71 (defun %log-file-path (output-root channel-name year month day type)
  72   (make-pathname
  73    :defaults output-root
  74    :directory (append (pathname-directory output-root)
  75                       (list
  76                        (string-left-trim '(#\#) channel-name)
  77                        (format nil "~4,'0D-~2,'0D" year month)))
  78    :name (make-output-name channel-name year month day)
  79    :type type))
  80
  81 (defgeneric log-file-path (output-root channel-name year month day format))
  82
  83 (defmethod log-file-path (output-root channel-name year month day (format (eql :raw)))
  84   (%log-file-path output-root channel-name year month day "raw"))
  85
  86 (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
  87   (%log-file-path output-root channel-name year month day "sexp"))
  88
  89 (defmethod log-file-path (output-root channel-name year month day (format (eql :text)))
  90   (%log-file-path output-root channel-name year month day "txt"))
  91
  92
  93 (defun log-file-path-utime (output-root channel-name format utime)
  94   (multiple-value-bind
  95         (second minute hour day month year day-of-week daylight-p zone)
  96       (decode-universal-time utime)
  97     (declare (ignore second minute hour day-of-week daylight-p zone))
  98     (log-file-path output-root channel-name year month day format)))
  99
 100 (defun get-stream (channel istream)
 101   (elt (streams channel) istream))
 102
 103 (defun (setf get-stream) (value channel istream)
 104   (setf (elt (streams channel) istream) value))
 105
 106 (defun get-format (logger istream)
 107   (elt (formats logger) istream))
 108
 109 (defun get-output-name (channel istream)
 110   (elt (current-output-names channel) istream))
 111
 112 (defun (setf get-output-name) (value channel istream)
 113   (setf (elt (current-output-names channel) istream) value))
 114
 115 (defun ensure-output-stream-for-unichannel (utime logger channel istream)
 116   (let ((name (make-output-name-utime (name channel) utime)))
 117     (unless (string= name (get-output-name channel istream))
 118       (when (get-stream channel istream)
 119         (write-file-footer (get-format logger istream)
 120                            (name channel)
 121                            (get-stream channel istream))
 122         (close (get-stream channel istream)))
 123       (setf (get-output-name channel istream) name)
 124       (let ((path (log-file-path-utime (output-root channel) (name channel)
 125                                        (get-format logger istream) utime)))
 126         (unless (probe-file path)
 127           (ensure-directories-exist path)
 128           (setf (get-stream channel istream)
 129                 (open path :direction :output :if-exists :error
 130                       :if-does-not-exist :create))
 131           (write-file-header (get-format logger istream)
 132                              (name channel)
 133                               (get-stream channel istream))
 134           (close (get-stream channel istream)))
 135         (setf (get-stream channel istream)
 136               (open path :direction :output :if-exists :append
 137                     :if-does-not-exist :error))))))
 138
 139 (defun ensure-output-stream (utime logger channel istream)
 140   "Ensures that *output-stream* is correct."
 141   (cond
 142    ((streamp (user-output logger))
 143     (unless (get-stream channel istream)
 144       (setf (get-stream channel istream) (user-output logger))))
 145    ((pathnamep (user-output logger))
 146     (cond
 147      ((unichannel logger)
 148       (ensure-output-stream-for-unichannel utime logger channel istream))
 149      (t
 150       (setf (get-stream channel istream)
 151         (open (user-output logger) :direction :output :if-exists :append)))))))
 152
 153 (defun format-utime (utime)
 154   (multiple-value-bind
 155         (second minute hour day-of-month month year day-of-week daylight-p zone)
 156       (decode-universal-time utime)
 157     (declare (ignore day-of-month month year day-of-week daylight-p zone))
 158     (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
 159
 160 (defun format-utime-short(utime)
 161   (multiple-value-bind
 162         (second minute hour day-of-month month year day-of-week daylight-p zone)
 163       (decode-universal-time utime)
 164     (declare (ignore second day-of-month month year day-of-week daylight-p zone))
 165     (format nil "~2,'0D:~2,'0D" hour minute)))
 166
 167 (defun user-address (msg)
 168   (let ((split (split *user-address-scanner* (raw-message-string msg)
 169                       :with-registers-p t)))
 170     (if (second split)
 171         (second split)
 172         "")))
 173
 174 (defun need-user-address? (type)
 175   (not (or (eq :action type) (eq :privmsg type))))
 176
 177 (defgeneric %output-event (format stream utime type channel source text msg unichannel))
 178
 179 (defmethod %output-event ((format t) stream utime type channel source text
 180                           msg unichannel)
 181   (%output-event :raw stream utime type channel source text msg unichannel))
 182
 183 (defmethod %output-event ((format (eql :raw)) stream utime type channel source text
 184                           msg unichannel)
 185   (declare (ignore unichannel))
 186   (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string msg))))
 187
 188 (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text
 189                           msg unichannel)
 190   (if unichannel
 191       (format stream "(~S ~S ~S ~S ~S)~%" utime type source text
 192               (when (need-user-address? type) (user-address msg)))
 193     (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel
 194             text (when (need-user-address? type) (user-address msg)))))
 195
 196 (defmethod %output-event ((format (eql :text)) stream utime type channel source text
 197                           msg unichannel)
 198   (format stream "~A " (format-utime utime))
 199   (when (and (null unichannel) channel)
 200     (format stream "[~A] " channel))
 201
 202   (let ((user-address (when (need-user-address? type)  (user-address msg))))
 203     (case type
 204       (:privmsg
 205        (format stream "<~A> ~A" source text))
 206       (:action
 207        (format stream "*~A* ~A" source text))
 208       (:join
 209        (format stream "~A [~A] has joined ~A" source user-address channel))
 210       (:part
 211        (format stream "-!- ~A [~A] has left ~A" source user-address channel))
 212       (:nick
 213        (format stream "-!- ~A is now known as ~A" source text))
 214       (:kick
 215        (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel))
 216       (:quit
 217        (format stream "-!- ~A [~A] has quit [~A]" source user-address text))
 218       (:mode
 219        (format stream "-!- ~A has set mode ~A"  source text))
 220       (:topic
 221        (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text))
 222       (:notice
 223        (format stream "-~A:~A- ~A" source channel text))
 224       (t
 225      (warn "Unhandled msg type ~A." type))))
 226   (write-char #\Newline stream))
 227
 228 (defun output-event-for-a-stream (msg type channel text logger istream)
 229   (ensure-output-stream (received-time msg) logger channel istream)
 230   (%output-event  (get-format logger istream) (get-stream channel istream)
 231                   (received-time msg) type (name channel) (source msg) text msg
 232                   (unichannel logger))
 233   (force-output (get-stream channel istream)))
 234
 235 (defun output-event (msg type channel-name &optional text)
 236   (dolist (logger *loggers*)
 237     (case type
 238       ((:quit :nick)
 239        (dolist (channel (channels logger))
 240          (dotimes (i (length (formats logger)))
 241            (output-event-for-a-stream msg type channel text logger i))))
 242       (t
 243        (let* ((channel (find channel-name (the list (channels logger))
 244                              :test #'string-equal :key #'name)))
 245          (when channel
 246            (dotimes (i (length (formats logger)))
 247              (output-event-for-a-stream msg type channel text logger i))))))))
 248
 249 (defun privmsg-hook (msg)
 250   (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg)))
 251
 252 (defun action-hook (msg)
 253   (output-event msg :action (first (arguments msg))
 254                 (subseq (trailing-argument msg) 8
 255                         (- (length (trailing-argument msg)) 1))))
 256
 257 (defun nick-hook (msg)
 258   (output-event msg :nick nil (trailing-argument msg)))
 259
 260 (defun part-hook (msg)
 261   (output-event msg :part (first (arguments msg))))
 262
 263 (defun quit-hook (msg)
 264   (output-event msg :quit (trailing-argument msg)))
 265
 266 (defun join-hook (msg)
 267   (output-event msg :join (trailing-argument msg)))
 268
 269 (defun kick-hook (msg)
 270   (output-event msg :kick (first (arguments msg))))
 271
 272 (defun notice-hook (msg)
 273   (output-event msg :notice (first (arguments msg)) (trailing-argument msg)))
 274
 275 (defun topic-hook (msg)
 276   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 277
 278 (defun mode-hook (msg)
 279   (output-event msg :mode (first (arguments msg))))
 280
 281 (defun make-channels (names formats output)
 282   (loop for i from 0 to (1- (length names))
 283         collect
 284         (make-instance 'channel
 285                        :name (nth i names)
 286                        :streams (make-array (length formats) :initial-element nil)
 287                        :output-root (when (and (pathnamep output)
 288                                                (null (pathname-name output)))
 289                                       output)
 290                        :current-output-names (make-array (length formats)
 291                                                          :initial-element nil))))
 292
 293 (defun is-unichannel-output (user-output)
 294   "Returns T if output is setup for a single channel directory structure."
 295   (and (pathnamep user-output) (null (pathname-name user-output))))
 296
 297 (defun create-logger (nick server &key channels output
 298                       (logging-stream t)
 299                       (async t)
 300                       (formats '(:text)))
 301   "OUTPUT may be a pathname or a stream"
 302   ;; check arguments
 303   (assert channels)
 304   (assert formats)
 305   (if (atom channels)
 306       (setq channels (list channels)))
 307   (if (atom formats)
 308       (setq formats (list formats)))
 309   (if (stringp output)
 310       (setq output (parse-namestring output)))
 311   (let* ((conn  (connect :nickname nick :server server
 312                          :logging-stream logging-stream))
 313          (logger (make-instance
 314                   'logger
 315                   :connection conn
 316                   :nick nick
 317                   :server server
 318                   :channels (make-channels channels formats output)
 319                   :user-output output
 320                   :formats formats
 321                   :unichannel (is-unichannel-output output))))
 322
 323     (mapc #'(lambda (channel) (join conn channel)) channels)
 324     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 325     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 326     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 327     (add-hook conn 'irc::irc-part-message 'part-hook)
 328     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 329     (add-hook conn 'irc::irc-join-message 'join-hook)
 330     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 331     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 332     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 333     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 334     (cond
 335       (async
 336        #+sbcl (add-asynchronous-message-handler conn)
 337        #-sbcl (read-message-loop conn))
 338       (t
 339        (read-message-loop conn)))
 340     logger))
 341
 342 (defun quit-logger (nick)
 343   "Quit the active connection with nick and remove from active list."
 344   (let ((logger (find-logger-with-nick nick)))
 345     (cond
 346       ((null logger)
 347        (warn "No active connection found with nick ~A." nick)
 348        nil)
 349       (t
 350        (irc:quit (connection logger))
 351        (sleep 1)
 352        (dolist (channel (channels logger))
 353          (dotimes (i (length (streams channel)))
 354          (when (streamp (get-stream channel i))
 355            (close (get-stream channel i))
 356            (setf (get-stream channel i) nil))))
 357        (setq *loggers*
 358              (delete nick *loggers*  :test #'string-equal :key #'nickname))
 359        t))))
 360
 361 (defun add-logger (nick server &key channels output
 362                    (logging-stream t)
 363                    (async t)
 364                    (formats '(:text)))
 365   (when (find-logger-with-nick nick)
 366     (warn "Closing previously active connection.")
 367     (quit-logger nick))
 368   (let ((logger
 369          (create-logger nick server :channels channels :output output
 370                         :logging-stream logging-stream
 371                         :async async :formats formats)))
 372     (push logger *loggers*)
 373     logger))
 374
 375 (defun add-hook-logger (logger msg hook)
 376   (add-hook (connection logger) msg hook))
 377
 378 (defun remove-hook-logger (logger msg)
 379   (remove-hook (connection logger) msg))