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 (defvar *daemon-monitor-process* nil "Process of background monitor.")
  10
  11 (defclass channel ()
  12   ((name :initarg :name :reader name
  13          :documentation "Name of channel.")
  14    (streams :initarg :streams :reader streams
  15             :documentation "List of output streams.")
  16    (output-root :initarg :output-root :reader output-root)
  17    (current-output-names :initarg :current-output-names :accessor current-output-names)))
  18
  19
  20 (defclass logger ()
  21   ((connection :initarg :connection :reader connection
  22                :documentation "IRC connection object.")
  23    (handler :initform nil :accessor handler
  24             :documentation "Background handler process.")
  25    (nick :initarg :nick :reader nickname
  26          :documentation "Nickname of the bot.")
  27    (password :initarg :password :reader password
  28              :documentation "Nickname's nickserver password.")
  29    (server :initarg :server :reader server
  30            :documentation "Connected IRC server.")
  31    (channel-names :initarg :channel-names :accessor channel-names
  32                   :documentation "List of channel names.")
  33    (realname :initarg :realname :reader realname
  34            :documentation "Realname for cl-irc")
  35    (username :initarg :username :reader username
  36            :documentation "Username for cl-irc")
  37    (logging-stream :initarg :logging-stream :reader logging-stream
  38                    :documentation "logging-stream for cl-irc.")
  39    (channels :initarg :channels :accessor channels
  40              :documentation "List of channels.")
  41    (user-output :initarg :user-output :reader user-output
  42                 :documentation
  43                 "Output parameter from user, maybe stream or pathname.")
  44    (unichannel :initarg :unichannel :reader unichannel :type boolean
  45                :documentation "T if user-output is directory for individual channel output.")
  46    (formats :initarg :formats :reader formats
  47                   :documentation
  48                   "A list of output formats.")
  49    (warning-message-utime :initform nil :accessor warning-message-utime
  50                   :documentation
  51                   "Time of last, potentially active, warning message.")))
  52
  53 (defvar *loggers* nil "List of active loggers.")
  54
  55 (defparameter *user-address-scanner*
  56   (create-scanner
  57    '(:sequence #\!
  58      (:register
  59       (:greedy-repetition 1 nil :non-whitespace-char-class)))
  60    :case-insensitive-mode t))
  61
  62 (defun find-logger-with-nick (nick)
  63   (find nick (the list *loggers*) :test #'string-equal :key #'nickname))
  64
  65 (defun find-logger-with-connection (conn)
  66   (find conn (the list *loggers*) :test #'eq :key #'connection))
  67
  68 (defun canonicalize-channel-name (name)
  69   (string-left-trim '(#\#) name))
  70
  71 (defun find-channel-with-name (logger name)
  72   (find name (the list (channels logger)) :test #'string-equal :key #'name))
  73
  74 (defun make-output-name (name year month day)
  75     (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name)
  76             year month day))
  77
  78 (defun make-output-name-utime (name utime)
  79   (multiple-value-bind
  80         (second minute hour day-of-month month year day-of-week daylight-p zone)
  81       (decode-universal-time utime)
  82     (declare (ignore second minute hour day-of-week daylight-p zone))
  83     (make-output-name name year month day-of-month)))
  84
  85 (defgeneric write-file-header (format channel-name stream))
  86
  87 (defmethod write-file-header ((format t) channel-name stream)
  88   (declare (ignore channel-name stream))
  89   )
  90
  91 (defgeneric write-file-footer (format channel-name stream))
  92
  93 (defmethod write-file-footer ((format t) channel-name stream)
  94   (declare (ignore channel-name stream))
  95   )
  96
  97 (defun %log-file-path (output-root channel-name year month day type)
  98   (make-pathname
  99    :defaults output-root
 100    :directory (append (pathname-directory output-root)
 101                       (list
 102                        (string-left-trim '(#\#) channel-name)
 103                        (format nil "~4,'0D-~2,'0D" year month)))
 104    :name (make-output-name channel-name year month day)
 105    :type type))
 106
 107 (defgeneric log-file-path (output-root channel-name year month day format))
 108
 109 (defmethod log-file-path (output-root channel-name year month day
 110                           (format (eql :raw)))
 111   (%log-file-path output-root channel-name year month day "raw"))
 112
 113 (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
 114   (%log-file-path output-root channel-name year month day "sexp"))
 115
 116 (defmethod log-file-path (output-root channel-name year month day (format (eql :text)))
 117   (%log-file-path output-root channel-name year month day "txt"))
 118
 119 (defmethod log-file-path (output-root channel-name year month day (format string))
 120   (%log-file-path output-root channel-name year month day format))
 121
 122
 123 (defun log-file-path-utime (output-root channel-name format utime)
 124   (multiple-value-bind
 125         (second minute hour day month year day-of-week daylight-p zone)
 126       (decode-universal-time utime)
 127     (declare (ignore second minute hour day-of-week daylight-p zone))
 128     (log-file-path output-root channel-name year month day format)))
 129
 130 (defun get-stream (channel istream)
 131   (elt (streams channel) istream))
 132
 133 (defun (setf get-stream) (value channel istream)
 134   (setf (elt (streams channel) istream) value))
 135
 136 (defun get-format (logger istream)
 137   (elt (formats logger) istream))
 138
 139 (defun get-output-name (channel istream)
 140   (elt (current-output-names channel) istream))
 141
 142 (defun (setf get-output-name) (value channel istream)
 143   (setf (elt (current-output-names channel) istream) value))
 144
 145 (defun ensure-output-stream-for-unichannel (utime logger channel istream)
 146   (let ((name (make-output-name-utime (name channel) utime)))
 147     (unless (string= name (get-output-name channel istream))
 148       (when (get-stream channel istream)
 149         (write-file-footer (get-format logger istream)
 150                            (name channel)
 151                            (get-stream channel istream))
 152         (close (get-stream channel istream)))
 153       (setf (get-output-name channel istream) name)
 154       (let ((path (log-file-path-utime (output-root channel) (name channel)
 155                                        (get-format logger istream) utime)))
 156         (unless (probe-file path)
 157           (ensure-directories-exist path)
 158           (setf (get-stream channel istream)
 159                 (open path :direction :output :if-exists :error
 160                       :if-does-not-exist :create))
 161           (write-file-header (get-format logger istream)
 162                              (name channel)
 163                               (get-stream channel istream))
 164           (close (get-stream channel istream)))
 165         (setf (get-stream channel istream)
 166               (open path :direction :output :if-exists :append
 167                     :if-does-not-exist :error))))))
 168
 169 (defun ensure-output-stream (utime logger channel istream)
 170   "Ensures that *output-stream* is correct."
 171   (cond
 172    ((streamp (user-output logger))
 173     (unless (get-stream channel istream)
 174       (setf (get-stream channel istream) (user-output logger))))
 175    ((pathnamep (user-output logger))
 176     (cond
 177      ((unichannel logger)
 178       (ensure-output-stream-for-unichannel utime logger channel istream))
 179      (t
 180       (setf (get-stream channel istream)
 181         (open (user-output logger) :direction :output :if-exists :append)))))))
 182
 183 (defun format-date-time (utime)
 184   (multiple-value-bind
 185         (second minute hour day-of-month month year day-of-week daylight-p zone)
 186       (decode-universal-time utime)
 187     (declare (ignore day-of-week daylight-p zone))
 188     (format nil "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minute second)))
 189
 190 (defun format-utime (utime)
 191   (multiple-value-bind
 192         (second minute hour day-of-month month year day-of-week daylight-p zone)
 193       (decode-universal-time utime)
 194     (declare (ignore day-of-month month year day-of-week daylight-p zone))
 195     (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
 196
 197 (defun format-utime-short (utime)
 198   (multiple-value-bind
 199         (second minute hour day-of-month month year day-of-week daylight-p zone)
 200       (decode-universal-time utime)
 201     (declare (ignore second day-of-month month year day-of-week daylight-p zone))
 202     (format nil "~2,'0D:~2,'0D" hour minute)))
 203
 204 (defun user-address (msg)
 205   (let ((split (split *user-address-scanner* (raw-message-string msg)
 206                       :with-registers-p t)))
 207     (if (second split)
 208         (second split)
 209         "")))
 210
 211 (defun need-user-address? (type)
 212   (not (or (eq :action type) (eq :privmsg type))))
 213
 214 (defgeneric %output-event (format stream utime type channel source text msg
 215                            unichannel))
 216
 217 (defmethod %output-event ((format t) stream utime type channel source text
 218                           msg unichannel)
 219   (%output-event :raw stream utime type channel source text msg unichannel))
 220
 221 (defmethod %output-event ((format (eql :raw)) stream utime type channel source
 222                           text msg unichannel)
 223   (declare (ignore utime type channel source text text unichannel ))
 224   (format stream "~S~%" (string-right-trim '(#\return)
 225                                            (raw-message-string msg))))
 226
 227 (defun last-sexp-field (type msg)
 228   (cond
 229    ((null msg)
 230     nil)
 231    ((eq type :kick)
 232     (trailing-argument msg))
 233    ((need-user-address? type)
 234     (user-address msg))))
 235
 236 (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text
 237                           msg unichannel)
 238   (if unichannel
 239       (format stream "(~S ~S ~S ~S ~S)~%" utime type source text (last-sexp-field type msg))
 240     (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel text
 241             (last-sexp-field type msg))))
 242
 243 (defmethod %output-event ((format (eql :text)) stream utime type channel source text
 244                           msg unichannel)
 245   (format stream "~A " (format-utime utime))
 246   (when (and (null unichannel) channel)
 247     (format stream "[~A] " channel))
 248
 249   (let ((user-address (when (and msg (need-user-address? type)) (user-address msg))))
 250     (case type
 251       (:privmsg
 252        (format stream "<~A> ~A" source text))
 253       (:action
 254        (format stream "*~A* ~A" source text))
 255       (:join
 256        (format stream "~A [~A] has joined ~A" source user-address channel))
 257       (:part
 258        (format stream "-!- ~A [~A] has left ~A" source user-address channel))
 259       (:nick
 260        (format stream "-!- ~A is now known as ~A" source text))
 261       (:kick
 262        (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel))
 263       (:quit
 264        (format stream "-!- ~A [~A] has quit [~A]" source user-address (if text text "")))
 265       (:mode
 266        (format stream "-!- ~A has set mode ~A"  source text))
 267       (:topic
 268        (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text))
 269       (:notice
 270        (format stream "-~A:~A- ~A" source channel text))
 271       (:daemon
 272        (format stream "-!!!- ~A" text))
 273       (:server
 274        (format stream "-!!!- server send message ~A" source channel text))
 275       (:unhandled
 276        (format stream "-!!!- ~A" text))
 277       (t
 278      (warn "Unhandled msg type ~A." type))))
 279   (write-char #\Newline stream))
 280
 281 (defun output-event-for-a-stream (msg type channel text logger istream)
 282   (ensure-output-stream (received-time msg) logger channel istream)
 283   (%output-event  (get-format logger istream) (get-stream channel istream)
 284                   (received-time msg) type (name channel) (source msg) text msg
 285                   (unichannel logger))
 286   (force-output (get-stream channel istream)))
 287
 288 (defun log-daemon-message (logger fmt &rest args)
 289   (let ((text (apply #'format nil fmt args))
 290         (time (get-universal-time)))
 291     (dolist (channel (channels logger))
 292       (dotimes (istream (formats logger))
 293         (ensure-output-stream time logger channel istream)
 294         (%output-event  (get-format logger istream) (get-stream channel istream)
 295                         time :daemon nil nil text nil
 296                         (unichannel logger))
 297         (force-output (get-stream channel istream))))))
 298
 299 (defvar *msg*)
 300 (defun output-event (msg type channel-name &optional text)
 301   (setq *msg* msg)
 302   (dolist (logger *loggers*)
 303     (case type
 304       ((:quit :nick)
 305        (let* ((user (find-user (connection logger)
 306                                (case type
 307                                  (:nick (source msg))
 308                                  (:quit (source msg)))))
 309               (channels (when user (cl-irc::channels user))))
 310          (dolist (channel (mapcar
 311                            #'(lambda (name) (find-channel-with-name logger name))
 312                            (mapcar #'cl-irc::name channels)))
 313            (when channel
 314              (dotimes (i (length (formats logger)))
 315                (output-event-for-a-stream msg type channel text logger i))))))
 316       (:server
 317          (dolist (channel (channels logger))
 318            (dotimes (i (length (formats logger)))
 319              (output-event-for-a-stream msg type channel text logger i))))
 320       (t
 321        (let* ((channel (find-channel-with-name logger channel-name)))
 322          (when channel
 323            (dotimes (i (length (formats logger)))
 324              (output-event-for-a-stream msg type channel text logger i))))))))
 325
 326 (defun privmsg-hook (msg)
 327   (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg)))
 328
 329 (defun action-hook (msg)
 330   (output-event msg :action (first (arguments msg))
 331                 (subseq (trailing-argument msg) 8
 332                         (- (length (trailing-argument msg)) 1))))
 333
 334 (defun nick-hook (msg)
 335   (output-event msg :nick nil (trailing-argument msg)))
 336
 337 (defun part-hook (msg)
 338   (output-event msg :part (first (arguments msg))))
 339
 340 (defun quit-hook (msg)
 341   (output-event msg :quit nil (trailing-argument msg)))
 342
 343 (defun join-hook (msg)
 344   (output-event msg :join (trailing-argument msg)))
 345
 346 (defun kick-hook (msg)
 347   (output-event msg :kick (first (arguments msg))))
 348
 349 (defun notice-hook (msg)
 350   (if (and (string-equal (source msg) "NickServ")
 351            (string-equal "owned by someone else" (trailing-argument msg)))
 352       (let ((logger (find-logger-with-connection (connection msg))))
 353         (if logger
 354             (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger)))
 355             (warn "NickServ asks for identity with connection not found.")))
 356       (output-event msg :notice (first (arguments msg)) (trailing-argument msg))))
 357
 358 (defun topic-hook (msg)
 359   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 360
 361 (defun mode-hook (msg)
 362   (output-event msg :mode (first (arguments msg))
 363                 (format nil "~{~A~^ ~}" (cdr (arguments msg)))))
 364
 365 (defun make-a-channel (name formats output)
 366   (make-instance 'channel
 367                  :name name
 368                  :streams (make-array (length formats) :initial-element nil)
 369                  :output-root (when (and (pathnamep output)
 370                                          (null (pathname-name output)))
 371                                 output)
 372                  :current-output-names (make-array (length formats)
 373                                                    :initial-element nil)))
 374
 375 (defun make-channels (names formats output)
 376   (loop for i from 0 to (1- (length names))
 377         collect (make-a-channel (elt names i) formats output)))
 378
 379 (defun is-unichannel-output (user-output)
 380   "Returns T if output is setup for a single channel directory structure."
 381   (and (pathnamep user-output) (null (pathname-name user-output))))
 382
 383 (defun create-logger (nick server &key channels output password
 384                                        realname username
 385                                        (logging-stream t) (formats '(:text)))
 386   "OUTPUT may be a pathname or a stream"
 387   ;; check arguments
 388   (assert formats)
 389   (if (and channels (atom channels))
 390       (setq channels (list channels)))
 391   (if (atom formats)
 392       (setq formats (list formats)))
 393   (if (stringp output)
 394       (setq output (parse-namestring output)))
 395   (let* ((conn (connect :nickname nick :server server
 396                          :username username :realname realname
 397                          :logging-stream logging-stream))
 398          (logger (make-instance
 399                   'logger
 400                   :connection conn
 401                   :nick nick
 402                   :password password
 403                   :server server
 404                   :channels (make-channels channels formats output)
 405                   :channel-names channels
 406                   :username username
 407                   :realname realname
 408                   :logging-stream logging-stream
 409                   :user-output output
 410                   :formats formats
 411                   :unichannel (is-unichannel-output output))))
 412
 413     (mapc #'(lambda (channel) (join conn channel)) channels)
 414     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 415     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 416     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 417     (add-hook conn 'irc::irc-part-message 'part-hook)
 418     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 419     (add-hook conn 'irc::irc-join-message 'join-hook)
 420     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 421     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 422     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 423     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 424     (add-hook conn 'irc::irc-rpl_killdone-message 'warning-hook)
 425     (add-hook conn 'irc::irc-rpl_closing-message 'warning-hook)
 426     (unless *daemon-monitor-process*
 427       (setq *daemon-monitor-process* (cl-irc::start-process 'daemon-monitor "logger-monitor")))
 428     logger))
 429
 430 (defun start-logger (logger async)
 431   (if async
 432       (setf (handler logger)
 433         (start-background-message-handler (connection logger)))
 434       (read-message-loop (connection logger))))
 435
 436 (defun remove-logger (nick)
 437   "Quit the active connection with nick and remove from active list."
 438   (let ((logger (find-logger-with-nick nick)))
 439     (cond
 440       ((null logger)
 441        (warn "No active connection found with nick ~A." nick)
 442        nil)
 443       (t
 444        (irc:quit (connection logger))
 445        (stop-background-message-handler (handler logger))
 446        (sleep 1)
 447        (dolist (channel (channels logger))
 448          (let ((c (connection logger)))
 449            (when c
 450              (ignore-errors (remove-channel c (find-channel c (name channel)))))))
 451        (setq *loggers*
 452              (delete nick *loggers*  :test #'string-equal :key #'nickname))
 453        t))))
 454
 455 (defun add-logger (nick server &key channels output (password "")
 456                                     realname username
 457                    (logging-stream t) (async t) (formats '(:text)))
 458   (when (find-logger-with-nick nick)
 459     (warn "Closing previously active connection.")
 460     (remove-logger nick))
 461   (let ((logger (create-logger nick server :channels channels :output output
 462                                :logging-stream logging-stream :password password
 463                                :realname realname :username username
 464                                :formats formats)))
 465     (push logger *loggers*)
 466     (start-logger logger async)
 467     logger))
 468
 469 (defun add-channel-logger (logger channel-name)
 470   (cond
 471     ((find-channel-with-name logger channel-name)
 472      (warn "Channel ~A already in logger ~A." channel-name logger)
 473      nil)
 474     (t
 475      (let ((channel (make-a-channel channel-name (formats logger) (user-output logger))))
 476        (join (connection logger) channel-name)
 477        (push channel (channels logger))
 478        (push channel-name (channel-names logger))))))
 479
 480 (defun remove-channel-logger (logger channel-name)
 481   (let ((channel (find-channel-with-name logger channel-name)))
 482     (cond
 483       (channel
 484        (part (connection logger) channel-name)
 485        (dotimes (i (length (streams channel)))
 486          (when (streamp (get-stream channel i))
 487            (close (get-stream channel i))
 488            (setf (get-stream channel i) nil)))
 489        (setf (channels logger) (delete channel-name (channels logger)
 490                                        :test #'string-equal
 491                                        :key #'name))
 492        (setf (channel-names logger) (delete channel-name (channel-names logger)
 493                                             :test #'string-equal))
 494        t)
 495       (t
 496        (warn "Channel name ~A not found in logger ~A."
 497              channel-name logger)
 498        nil))))
 499
 500 (defun add-hook-logger (logger class hook)
 501   (add-hook (connection logger) class hook))
 502
 503 (defun remove-hook-logger (logger class hook)
 504   (remove-hook (connection logger) class hook))
 505
 506 (defvar *warning-message-utime* nil)
 507
 508 (defun warning-hook (msg)
 509   (let ((logger (find-logger-with-connection (connection msg))))
 510     (output-event msg :server
 511                   (format nil "~{~A~^ ~} ~A)"
 512                           (arguments msg)
 513                           (trailing-argument msg)))
 514     (when logger
 515       (setf (warning-message-utime logger) (get-universal-time)))))
 516
 517 (defun daemon-sleep (seconds)
 518   #-allegro (sleep seconds)
 519   #+allegro (mp:process-sleep seconds))
 520
 521 (defun log-disconnection (logger)
 522   ;; avoid generating too many reconnect messages in the logs
 523   (when (< (- (get-universal-time) (warning-message-utime logger)) 300)
 524     (log-daemon-message logger "Disconnected. Attempting reconnection at ~A."
 525                         (format-date-time (get-universal-time)))))
 526
 527 (defun log-reconnection (logger)
 528   (log-daemon-message logger
 529                       "Connection restablished at ~A." (format-date-time (get-universal-time))))
 530
 531 (defun attempt-reconnection (logger)
 532   (log-disconnection logger)
 533   (setf (connection logger) nil)
 534   (let ((connection (connect :nickname (nickname logger)
 535                              :server (server logger)
 536                              :channel-names (channel-names logger)
 537                              :username (username logger)
 538                              :realname (realname logger)
 539                              :logging-stream (logging-stream logger))))
 540     (when (and connection (cl-irc::connectedp connection))
 541       (setf (connection logger) connection)
 542       (log-reconnection logger)
 543       t)))
 544
 545 (defun daemon-monitor ()
 546   "This function runs in the background and monitors the connection of the logger."
 547   ;; run forever
 548   (do ()
 549       ()
 550     (dolist (logger *loggers*)
 551       (do ((conn (connection logger))
 552            (warning-time (warning-message-utime logger) (warning-message-utime logger)))
 553           (warning-time)
 554         (cond
 555          ((> (- (get-universal-time) warning-time) 180)
 556           ;;give up frequent checking because no disconnection despite waiting
 557           (setf (warning-message-utime logger) nil))
 558          ((not (cl-irc::connectedp conn))
 559           (unless warning-time
 560             (setf (warning-message-utime logger) (get-universal-time)))
 561           (attempt-reconnection logger))
 562          (t
 563           (daemon-sleep 30)))))
 564     (daemon-sleep 600)))