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