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 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 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
  84                           (format (eql :raw)))
  85   (%log-file-path output-root channel-name year month day "raw"))
  86
  87 (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
  88   (%log-file-path output-root channel-name year month day "sexp"))
  89
  90 (defmethod log-file-path (output-root channel-name year month day (format (eql :text)))
  91   (%log-file-path output-root channel-name year month day "txt"))
  92
  93
  94 (defun log-file-path-utime (output-root channel-name format utime)
  95   (multiple-value-bind
  96         (second minute hour day month year day-of-week daylight-p zone)
  97       (decode-universal-time utime)
  98     (declare (ignore second minute hour day-of-week daylight-p zone))
  99     (log-file-path output-root channel-name year month day format)))
 100
 101 (defun get-stream (channel istream)
 102   (elt (streams channel) istream))
 103
 104 (defun (setf get-stream) (value channel istream)
 105   (setf (elt (streams channel) istream) value))
 106
 107 (defun get-format (logger istream)
 108   (elt (formats logger) istream))
 109
 110 (defun get-output-name (channel istream)
 111   (elt (current-output-names channel) istream))
 112
 113 (defun (setf get-output-name) (value channel istream)
 114   (setf (elt (current-output-names channel) istream) value))
 115
 116 (defun ensure-output-stream-for-unichannel (utime logger channel istream)
 117   (let ((name (make-output-name-utime (name channel) utime)))
 118     (unless (string= name (get-output-name channel istream))
 119       (when (get-stream channel istream)
 120         (write-file-footer (get-format logger istream)
 121                            (name channel)
 122                            (get-stream channel istream))
 123         (close (get-stream channel istream)))
 124       (setf (get-output-name channel istream) name)
 125       (let ((path (log-file-path-utime (output-root channel) (name channel)
 126                                        (get-format logger istream) utime)))
 127         (unless (probe-file path)
 128           (ensure-directories-exist path)
 129           (setf (get-stream channel istream)
 130                 (open path :direction :output :if-exists :error
 131                       :if-does-not-exist :create))
 132           (write-file-header (get-format logger istream)
 133                              (name channel)
 134                               (get-stream channel istream))
 135           (close (get-stream channel istream)))
 136         (setf (get-stream channel istream)
 137               (open path :direction :output :if-exists :append
 138                     :if-does-not-exist :error))))))
 139
 140 (defun ensure-output-stream (utime logger channel istream)
 141   "Ensures that *output-stream* is correct."
 142   (cond
 143    ((streamp (user-output logger))
 144     (unless (get-stream channel istream)
 145       (setf (get-stream channel istream) (user-output logger))))
 146    ((pathnamep (user-output logger))
 147     (cond
 148      ((unichannel logger)
 149       (ensure-output-stream-for-unichannel utime logger channel istream))
 150      (t
 151       (setf (get-stream channel istream)
 152         (open (user-output logger) :direction :output :if-exists :append)))))))
 153
 154 (defun format-utime (utime)
 155   (multiple-value-bind
 156         (second minute hour day-of-month month year day-of-week daylight-p zone)
 157       (decode-universal-time utime)
 158     (declare (ignore day-of-month month year day-of-week daylight-p zone))
 159     (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
 160
 161 (defun format-utime-short(utime)
 162   (multiple-value-bind
 163         (second minute hour day-of-month month year day-of-week daylight-p zone)
 164       (decode-universal-time utime)
 165     (declare (ignore second day-of-month month year day-of-week daylight-p zone))
 166     (format nil "~2,'0D:~2,'0D" hour minute)))
 167
 168 (defun user-address (msg)
 169   (let ((split (split *user-address-scanner* (raw-message-string msg)
 170                       :with-registers-p t)))
 171     (if (second split)
 172         (second split)
 173         "")))
 174
 175 (defun need-user-address? (type)
 176   (not (or (eq :action type) (eq :privmsg type))))
 177
 178 (defgeneric %output-event (format stream utime type channel source text msg
 179                            unichannel))
 180
 181 (defmethod %output-event ((format t) stream utime type channel source text
 182                           msg unichannel)
 183   (%output-event :raw stream utime type channel source text msg unichannel))
 184
 185 (defmethod %output-event ((format (eql :raw)) stream utime type channel source
 186                           text msg unichannel)
 187   (declare (ignore utime type channel source text text unichannel ))
 188   (format stream "~S~%" (string-right-trim '(#\return)
 189                                            (raw-message-string msg))))
 190
 191 (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text
 192                           msg unichannel)
 193   (if unichannel
 194       (format stream "(~S ~S ~S ~S ~S)~%" utime type source text
 195               (when (need-user-address? type) (user-address msg)))
 196     (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel
 197             text (when (need-user-address? type) (user-address msg)))))
 198
 199 (defmethod %output-event ((format (eql :text)) stream utime type channel source text
 200                           msg unichannel)
 201   (format stream "~A " (format-utime utime))
 202   (when (and (null unichannel) channel)
 203     (format stream "[~A] " channel))
 204
 205   (let ((user-address (when (need-user-address? type)  (user-address msg))))
 206     (case type
 207       (:privmsg
 208        (format stream "<~A> ~A" source text))
 209       (:action
 210        (format stream "*~A* ~A" source text))
 211       (:join
 212        (format stream "~A [~A] has joined ~A" source user-address channel))
 213       (:part
 214        (format stream "-!- ~A [~A] has left ~A" source user-address channel))
 215       (:nick
 216        (format stream "-!- ~A is now known as ~A" source text))
 217       (:kick
 218        (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel))
 219       (:quit
 220        (format stream "-!- ~A [~A] has quit [~A]" source user-address text))
 221       (:mode
 222        (format stream "-!- ~A has set mode ~A"  source text))
 223       (:topic
 224        (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text))
 225       (:notice
 226        (format stream "-~A:~A- ~A" source channel text))
 227       (t
 228      (warn "Unhandled msg type ~A." type))))
 229   (write-char #\Newline stream))
 230
 231 (defun output-event-for-a-stream (msg type channel text logger istream)
 232   (ensure-output-stream (received-time msg) logger channel istream)
 233   (%output-event  (get-format logger istream) (get-stream channel istream)
 234                   (received-time msg) type (name channel) (source msg) text msg
 235                   (unichannel logger))
 236   (force-output (get-stream channel istream)))
 237
 238 (defun output-event (msg type channel-name &optional text)
 239   (dolist (logger *loggers*)
 240     (case type
 241       ((:quit :nick)
 242        (dolist (channel (channels logger))
 243          (dotimes (i (length (formats logger)))
 244            (output-event-for-a-stream msg type channel text logger i))))
 245       (t
 246        (let* ((channel (find channel-name (the list (channels logger))
 247                              :test #'string-equal :key #'name)))
 248          (when channel
 249            (dotimes (i (length (formats logger)))
 250              (output-event-for-a-stream msg type channel text logger i))))))))
 251
 252 (defun privmsg-hook (msg)
 253   (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg)))
 254
 255 (defun action-hook (msg)
 256   (output-event msg :action (first (arguments msg))
 257                 (subseq (trailing-argument msg) 8
 258                         (- (length (trailing-argument msg)) 1))))
 259
 260 (defun nick-hook (msg)
 261   (output-event msg :nick nil (trailing-argument msg)))
 262
 263 (defun part-hook (msg)
 264   (output-event msg :part (first (arguments msg))))
 265
 266 (defun quit-hook (msg)
 267   (output-event msg :quit (trailing-argument msg)))
 268
 269 (defun join-hook (msg)
 270   (output-event msg :join (trailing-argument msg)))
 271
 272 (defun kick-hook (msg)
 273   (output-event msg :kick (first (arguments msg))))
 274
 275 (defun notice-hook (msg)
 276   (output-event msg :notice (first (arguments msg)) (trailing-argument msg)))
 277
 278 (defun topic-hook (msg)
 279   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 280
 281 (defun mode-hook (msg)
 282   (output-event msg :mode (first (arguments msg))))
 283
 284 (defun make-channels (names formats output)
 285   (loop for i from 0 to (1- (length names))
 286         collect
 287         (make-instance 'channel
 288                        :name (nth i names)
 289                        :streams (make-array (length formats) :initial-element nil)
 290                        :output-root (when (and (pathnamep output)
 291                                                (null (pathname-name output)))
 292                                       output)
 293                        :current-output-names (make-array (length formats)
 294                                                          :initial-element nil))))
 295
 296 (defun is-unichannel-output (user-output)
 297   "Returns T if output is setup for a single channel directory structure."
 298   (and (pathnamep user-output) (null (pathname-name user-output))))
 299
 300 (defun create-logger (nick server &key channels output
 301                       (logging-stream t)
 302                       (formats '(:text)))
 303   "OUTPUT may be a pathname or a stream"
 304   ;; check arguments
 305   (assert channels)
 306   (assert formats)
 307   (if (atom channels)
 308       (setq channels (list channels)))
 309   (if (atom formats)
 310       (setq formats (list formats)))
 311   (if (stringp output)
 312       (setq output (parse-namestring output)))
 313   (let* ((conn  (connect :nickname nick :server server
 314                          :logging-stream logging-stream))
 315          (logger (make-instance
 316                   'logger
 317                   :connection conn
 318                   :nick nick
 319                   :server server
 320                   :channels (make-channels channels formats output)
 321                   :user-output output
 322                   :formats formats
 323                   :unichannel (is-unichannel-output output))))
 324
 325     (mapc #'(lambda (channel) (join conn channel)) channels)
 326     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 327     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 328     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 329     (add-hook conn 'irc::irc-part-message 'part-hook)
 330     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 331     (add-hook conn 'irc::irc-join-message 'join-hook)
 332     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 333     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 334     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 335     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 336     logger))
 337
 338 (defun start-logger (logger async)
 339   (if async
 340       (read-message-loop-background (connection logger))
 341     (read-message-loop (connection logger))))
 342
 343 (defun quit-logger (nick)
 344   "Quit the active connection with nick and remove from active list."
 345   (let ((logger (find-logger-with-nick nick)))
 346     (cond
 347       ((null logger)
 348        (warn "No active connection found with nick ~A." nick)
 349        nil)
 350       (t
 351        (irc:quit (connection logger))
 352        (sleep 1)
 353        (dolist (channel (channels logger))
 354          (dotimes (i (length (streams channel)))
 355          (when (streamp (get-stream channel i))
 356            (close (get-stream channel i))
 357            (setf (get-stream channel i) nil))))
 358        (setq *loggers*
 359              (delete nick *loggers*  :test #'string-equal :key #'nickname))
 360        t))))
 361
 362 (defun add-logger (nick server &key channels output
 363                    (logging-stream t)
 364                    (async t)
 365                    (formats '(:text)))
 366   (when (find-logger-with-nick nick)
 367     (warn "Closing previously active connection.")
 368     (quit-logger nick))
 369   (let ((logger (create-logger nick server :channels channels :output output
 370                                :logging-stream logging-stream
 371                                :formats formats)))
 372     (push logger *loggers*)
 373     (start-logger logger async)
 374     logger))
 375
 376 (defun add-hook-logger (logger class hook)
 377   (add-hook (connection logger) class hook))
 378
 379 (defun remove-hook-logger (logger class hook)
 380   (remove-hook (connection logger) class hook))