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    (handler :initform nil :accessor handler
  22             :documentation "Background handler process.")
  23    (nick :initarg :nick :reader nickname
  24          :documentation "Nickname of the bot.")
  25    (password :initarg :password :reader password
  26              :documentation "Nickname's nickserver password.")
  27    (server :initarg :server :reader server
  28            :documentation "Connected IRC server.")
  29    (channels :initarg :channels :accessor channels
  30              :documentation "List of channels.")
  31    (user-output :initarg :user-output :reader user-output
  32                 :documentation
  33                 "Output parameter from user, maybe stream or pathname.")
  34    (unichannel :initarg :unichannel :reader unichannel :type boolean
  35                :documentation "T if user-output is directory for individual channel output.")
  36    (formats :initarg :formats :reader formats
  37                   :documentation
  38                   "A list of output formats.")))
  39
  40 (defvar *loggers* nil "List of active loggers.")
  41
  42 (defparameter *user-address-scanner*
  43   (create-scanner
  44    '(:sequence #\!
  45      (:register
  46       (:greedy-repetition 1 nil :non-whitespace-char-class)))
  47    :case-insensitive-mode t))
  48
  49 (defun find-logger-with-nick (nick)
  50   (find nick (the list *loggers*) :test #'string-equal :key #'nickname))
  51
  52 (defun find-logger-with-connection (conn)
  53   (find conn (the list *loggers*) :test #'eq :key #'connection))
  54
  55 (defun canonicalize-channel-name (name)
  56   (string-left-trim '(#\#) name))
  57
  58 (defun find-channel-with-name (logger name)
  59   (find name (the list (channels logger)) :test #'string-equal :key #'name))
  60
  61 (defun make-output-name (name year month day)
  62     (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name)
  63             year month day))
  64
  65 (defun make-output-name-utime (name utime)
  66   (multiple-value-bind
  67         (second minute hour day-of-month month year day-of-week daylight-p zone)
  68       (decode-universal-time utime)
  69     (declare (ignore second minute hour day-of-week daylight-p zone))
  70     (make-output-name name year month day-of-month)))
  71
  72 (defgeneric write-file-header (format channel-name stream))
  73
  74 (defmethod write-file-header ((format t) channel-name stream)
  75   (declare (ignore channel-name stream))
  76   )
  77
  78 (defgeneric write-file-footer (format channel-name stream))
  79
  80 (defmethod write-file-footer ((format t) channel-name stream)
  81   (declare (ignore channel-name stream))
  82   )
  83
  84 (defun %log-file-path (output-root channel-name year month day type)
  85   (make-pathname
  86    :defaults output-root
  87    :directory (append (pathname-directory output-root)
  88                       (list
  89                        (string-left-trim '(#\#) channel-name)
  90                        (format nil "~4,'0D-~2,'0D" year month)))
  91    :name (make-output-name channel-name year month day)
  92    :type type))
  93
  94 (defgeneric log-file-path (output-root channel-name year month day format))
  95
  96 (defmethod log-file-path (output-root channel-name year month day
  97                           (format (eql :raw)))
  98   (%log-file-path output-root channel-name year month day "raw"))
  99
 100 (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
 101   (%log-file-path output-root channel-name year month day "sexp"))
 102
 103 (defmethod log-file-path (output-root channel-name year month day (format (eql :text)))
 104   (%log-file-path output-root channel-name year month day "txt"))
 105
 106 (defmethod log-file-path (output-root channel-name year month day (format string))
 107   (%log-file-path output-root channel-name year month day format))
 108
 109
 110 (defun log-file-path-utime (output-root channel-name format utime)
 111   (multiple-value-bind
 112         (second minute hour day month year day-of-week daylight-p zone)
 113       (decode-universal-time utime)
 114     (declare (ignore second minute hour day-of-week daylight-p zone))
 115     (log-file-path output-root channel-name year month day format)))
 116
 117 (defun get-stream (channel istream)
 118   (elt (streams channel) istream))
 119
 120 (defun (setf get-stream) (value channel istream)
 121   (setf (elt (streams channel) istream) value))
 122
 123 (defun get-format (logger istream)
 124   (elt (formats logger) istream))
 125
 126 (defun get-output-name (channel istream)
 127   (elt (current-output-names channel) istream))
 128
 129 (defun (setf get-output-name) (value channel istream)
 130   (setf (elt (current-output-names channel) istream) value))
 131
 132 (defun ensure-output-stream-for-unichannel (utime logger channel istream)
 133   (let ((name (make-output-name-utime (name channel) utime)))
 134     (unless (string= name (get-output-name channel istream))
 135       (when (get-stream channel istream)
 136         (write-file-footer (get-format logger istream)
 137                            (name channel)
 138                            (get-stream channel istream))
 139         (close (get-stream channel istream)))
 140       (setf (get-output-name channel istream) name)
 141       (let ((path (log-file-path-utime (output-root channel) (name channel)
 142                                        (get-format logger istream) utime)))
 143         (unless (probe-file path)
 144           (ensure-directories-exist path)
 145           (setf (get-stream channel istream)
 146                 (open path :direction :output :if-exists :error
 147                       :if-does-not-exist :create))
 148           (write-file-header (get-format logger istream)
 149                              (name channel)
 150                               (get-stream channel istream))
 151           (close (get-stream channel istream)))
 152         (setf (get-stream channel istream)
 153               (open path :direction :output :if-exists :append
 154                     :if-does-not-exist :error))))))
 155
 156 (defun ensure-output-stream (utime logger channel istream)
 157   "Ensures that *output-stream* is correct."
 158   (cond
 159    ((streamp (user-output logger))
 160     (unless (get-stream channel istream)
 161       (setf (get-stream channel istream) (user-output logger))))
 162    ((pathnamep (user-output logger))
 163     (cond
 164      ((unichannel logger)
 165       (ensure-output-stream-for-unichannel utime logger channel istream))
 166      (t
 167       (setf (get-stream channel istream)
 168         (open (user-output logger) :direction :output :if-exists :append)))))))
 169
 170 (defun format-utime (utime)
 171   (multiple-value-bind
 172         (second minute hour day-of-month month year day-of-week daylight-p zone)
 173       (decode-universal-time utime)
 174     (declare (ignore day-of-month month year day-of-week daylight-p zone))
 175     (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
 176
 177 (defun format-utime-short(utime)
 178   (multiple-value-bind
 179         (second minute hour day-of-month month year day-of-week daylight-p zone)
 180       (decode-universal-time utime)
 181     (declare (ignore second day-of-month month year day-of-week daylight-p zone))
 182     (format nil "~2,'0D:~2,'0D" hour minute)))
 183
 184 (defun user-address (msg)
 185   (let ((split (split *user-address-scanner* (raw-message-string msg)
 186                       :with-registers-p t)))
 187     (if (second split)
 188         (second split)
 189         "")))
 190
 191 (defun need-user-address? (type)
 192   (not (or (eq :action type) (eq :privmsg type))))
 193
 194 (defgeneric %output-event (format stream utime type channel source text msg
 195                            unichannel))
 196
 197 (defmethod %output-event ((format t) stream utime type channel source text
 198                           msg unichannel)
 199   (%output-event :raw stream utime type channel source text msg unichannel))
 200
 201 (defmethod %output-event ((format (eql :raw)) stream utime type channel source
 202                           text msg unichannel)
 203   (declare (ignore utime type channel source text text unichannel ))
 204   (format stream "~S~%" (string-right-trim '(#\return)
 205                                            (raw-message-string msg))))
 206
 207 (defun last-sexp-field (type msg)
 208   (cond
 209    ((eq type :kick)
 210     (trailing-argument msg))
 211    ((need-user-address? type)
 212     (user-address msg))))
 213
 214 (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text
 215                           msg unichannel)
 216   (if unichannel
 217       (format stream "(~S ~S ~S ~S ~S)~%" utime type source text (last-sexp-field type msg))
 218     (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel text
 219             (last-sexp-field type msg))))
 220
 221 (defmethod %output-event ((format (eql :text)) stream utime type channel source text
 222                           msg unichannel)
 223   (format stream "~A " (format-utime utime))
 224   (when (and (null unichannel) channel)
 225     (format stream "[~A] " channel))
 226
 227   (let ((user-address (when (need-user-address? type)  (user-address msg))))
 228     (case type
 229       (:privmsg
 230        (format stream "<~A> ~A" source text))
 231       (:action
 232        (format stream "*~A* ~A" source text))
 233       (:join
 234        (format stream "~A [~A] has joined ~A" source user-address channel))
 235       (:part
 236        (format stream "-!- ~A [~A] has left ~A" source user-address channel))
 237       (:nick
 238        (format stream "-!- ~A is now known as ~A" source text))
 239       (:kick
 240        (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel))
 241       (:quit
 242        (format stream "-!- ~A [~A] has quit [~A]" source user-address (if text text "")))
 243       (:mode
 244        (format stream "-!- ~A has set mode ~A"  source text))
 245       (:topic
 246        (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text))
 247       (:notice
 248        (format stream "-~A:~A- ~A" source channel text))
 249       (t
 250      (warn "Unhandled msg type ~A." type))))
 251   (write-char #\Newline stream))
 252
 253 (defun output-event-for-a-stream (msg type channel text logger istream)
 254   (ensure-output-stream (received-time msg) logger channel istream)
 255   (%output-event  (get-format logger istream) (get-stream channel istream)
 256                   (received-time msg) type (name channel) (source msg) text msg
 257                   (unichannel logger))
 258   (force-output (get-stream channel istream)))
 259
 260 (defvar *msg*)
 261 (defun output-event (msg type channel-name &optional text)
 262   (setq *msg* msg)
 263   (dolist (logger *loggers*)
 264     (case type
 265       ((:quit :nick)
 266        (let* ((user (find-user (connection logger)
 267                                (case type
 268                                  (:nick (source msg))
 269                                  (:quit (source msg)))))
 270               (channels (when user (cl-irc::channels user))))
 271          (dolist (channel (mapcar
 272                            #'(lambda (name) (find-channel-with-name logger name))
 273                            (mapcar #'cl-irc::name channels)))
 274            (when channel
 275              (dotimes (i (length (formats logger)))
 276                (output-event-for-a-stream msg type channel text logger i))))))
 277       (t
 278        (let* ((channel (find-channel-with-name logger channel-name)))
 279          (when channel
 280            (dotimes (i (length (formats logger)))
 281              (output-event-for-a-stream msg type channel text logger i))))))))
 282
 283 (defun privmsg-hook (msg)
 284   (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg)))
 285
 286 (defun action-hook (msg)
 287   (output-event msg :action (first (arguments msg))
 288                 (subseq (trailing-argument msg) 8
 289                         (- (length (trailing-argument msg)) 1))))
 290
 291 (defun nick-hook (msg)
 292   (output-event msg :nick nil (trailing-argument msg)))
 293
 294 (defun part-hook (msg)
 295   (output-event msg :part (first (arguments msg))))
 296
 297 (defun quit-hook (msg)
 298   (output-event msg :quit nil (trailing-argument msg)))
 299
 300 (defun join-hook (msg)
 301   (output-event msg :join (trailing-argument msg)))
 302
 303 (defun kick-hook (msg)
 304   (output-event msg :kick (first (arguments msg))))
 305
 306 (defun notice-hook (msg)
 307   (if (and (string-equal (source msg) "NickServ")
 308            (string-equal "owned by someone else" (trailing-argument msg)))
 309       (let ((logger (find-logger-with-connection (connection msg))))
 310         (if logger
 311             (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger)))
 312             (warn "NickServ asks for identity with connection not found.")))
 313       (output-event msg :notice (first (arguments msg)) (trailing-argument msg))))
 314
 315 (defun topic-hook (msg)
 316   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 317
 318 (defun mode-hook (msg)
 319   (output-event msg :mode (first (arguments msg))
 320                 (format nil "~{~A~^ ~}" (cdr (arguments msg)))))
 321
 322 (defun make-a-channel (name formats output)
 323   (make-instance 'channel
 324                  :name name
 325                  :streams (make-array (length formats) :initial-element nil)
 326                  :output-root (when (and (pathnamep output)
 327                                          (null (pathname-name output)))
 328                                 output)
 329                  :current-output-names (make-array (length formats)
 330                                                    :initial-element nil)))
 331
 332 (defun make-channels (names formats output)
 333   (loop for i from 0 to (1- (length names))
 334         collect (make-a-channel (elt names i) formats output)))
 335
 336 (defun is-unichannel-output (user-output)
 337   "Returns T if output is setup for a single channel directory structure."
 338   (and (pathnamep user-output) (null (pathname-name user-output))))
 339
 340 (defun create-logger (nick server &key channels output password
 341                                        realname username
 342                                        (logging-stream t) (formats '(:text)))
 343   "OUTPUT may be a pathname or a stream"
 344   ;; check arguments
 345   (assert formats)
 346   (if (and channels (atom channels))
 347       (setq channels (list channels)))
 348   (if (atom formats)
 349       (setq formats (list formats)))
 350   (if (stringp output)
 351       (setq output (parse-namestring output)))
 352   (let* ((conn  (connect :nickname nick :server server
 353                          :username username :realname realname
 354                          :logging-stream logging-stream))
 355          (logger (make-instance
 356                   'logger
 357                   :connection conn
 358                   :nick nick
 359                   :password password
 360                   :server server
 361                   :channels (make-channels channels formats output)
 362                   :user-output output
 363                   :formats formats
 364                   :unichannel (is-unichannel-output output))))
 365
 366     (mapc #'(lambda (channel) (join conn channel)) channels)
 367     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 368     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 369     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 370     (add-hook conn 'irc::irc-part-message 'part-hook)
 371     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 372     (add-hook conn 'irc::irc-join-message 'join-hook)
 373     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 374     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 375     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 376     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 377     logger))
 378
 379 (defun start-logger (logger async)
 380   (if async
 381       (setf (handler logger)
 382         (start-background-message-handler (connection logger)))
 383       (read-message-loop (connection logger))))
 384
 385 (defun remove-logger (nick)
 386   "Quit the active connection with nick and remove from active list."
 387   (let ((logger (find-logger-with-nick nick)))
 388     (cond
 389       ((null logger)
 390        (warn "No active connection found with nick ~A." nick)
 391        nil)
 392       (t
 393        (irc:quit (connection logger))
 394        (stop-background-message-handler (handler logger))
 395        (sleep 1)
 396        (dolist (channel (channels logger))
 397          (let ((c (connection logger)))
 398            (when c
 399              (ignore-errors (remove-channel c (find-channel c (name channel)))))))
 400        (setq *loggers*
 401              (delete nick *loggers*  :test #'string-equal :key #'nickname))
 402        t))))
 403
 404 (defun add-logger (nick server &key channels output (password "")
 405                                     realname username
 406                    (logging-stream t) (async t) (formats '(:text)))
 407   (when (find-logger-with-nick nick)
 408     (warn "Closing previously active connection.")
 409     (remove-logger nick))
 410   (let ((logger (create-logger nick server :channels channels :output output
 411                                :logging-stream logging-stream :password password
 412                                :realname realname :username username
 413                                :formats formats)))
 414     (push logger *loggers*)
 415     (start-logger logger async)
 416     logger))
 417
 418 (defun add-channel-logger (logger channel-name)
 419   (cond
 420     ((find-channel-with-name logger channel-name)
 421      (warn "Channel ~A already in logger ~A." channel-name logger)
 422      nil)
 423     (t
 424      (let ((channel (make-a-channel channel-name (formats logger) (user-output logger))))
 425        (join (connection logger) channel-name)
 426        (push channel (channels logger))))))
 427
 428 (defun remove-channel-logger (logger channel-name)
 429   (let ((channel (find-channel-with-name logger channel-name)))
 430     (cond
 431       (channel
 432        (part (connection logger) channel-name)
 433        (dotimes (i (length (streams channel)))
 434          (when (streamp (get-stream channel i))
 435            (close (get-stream channel i))
 436            (setf (get-stream channel i) nil)))
 437        (setf (channels logger) (delete channel-name (channels logger)
 438                                        :test #'string-equal
 439                                        :key #'name))
 440        t)
 441       (t
 442        (warn "Channel name ~A not found in logger ~A."
 443              channel-name logger)
 444        nil))))
 445
 446 (defun add-hook-logger (logger class hook)
 447   (add-hook (connection logger) class hook))
 448
 449 (defun remove-hook-logger (logger class hook)
 450   (remove-hook (connection logger) class hook))
 451
 452 ;; before disconnect, server usually sends something like
 453 ;;
 454 ;; Closing Link: nick[ipaddr or hostname] by servername (reason)
 455 ;;  some other reasons are: "G-lined", "K-lined", and "Your host is
 456 ;;             trying to (re)connect too fast -- throttled"
 457 ;;
 458 ;; reconnect should wait 30 sec depending upon the throttle
 459 ;;
 460 ;; avoid too many reconnect messages in the logs
 461 ;;
 462 ;; grep'ing around the net-nittin-ir source, it looks like 361
 463 ;; rpl_killdone and 362 rpl_closing may refer to the closing link
 464 ;; error i mention, as in, modern ircds may use numerics for such
 465 ;; logging of unhandled numerics is good to do also