logger.lisp

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