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 (defvar *daemon-monitor-process* nil "Process of background monitor.")
  10 (defparameter *timeout* 60)
  11
  12 (defclass channel ()
  13   ((name :initarg :name :reader c-name
  14          :documentation "Name of channel.")
  15    (streams :initarg :streams :reader streams
  16             :documentation "List of output streams.")
  17    (output-root :initarg :output-root :reader output-root)
  18    (current-output-names :initarg :current-output-names :accessor current-output-names)))
  19
  20
  21 (defclass logger ()
  22   ((connection :initarg :connection :accessor connection
  23                :documentation "IRC connection object.")
  24    (handler :initform nil :accessor handler
  25             :documentation "Background handler process.")
  26    (nick :initarg :nick :reader l-nickname
  27          :documentation "Nickname of the bot.")
  28    (password :initarg :password :reader password
  29              :documentation "Nickname's nickserver password.")
  30    (server :initarg :server :reader server
  31            :documentation "Connected IRC server.")
  32    (channel-names :initarg :channel-names :accessor channel-names
  33                   :documentation "List of channel names.")
  34    (realname :initarg :realname :reader l-realname
  35            :documentation "Realname for cl-irc")
  36    (username :initarg :username :reader l-username
  37            :documentation "Username for cl-irc")
  38    (logging-stream :initarg :logging-stream :reader logging-stream
  39                    :documentation "logging-stream for cl-irc.")
  40    (channels :initarg :channels :accessor channels
  41              :documentation "List of channels.")
  42    (user-output :initarg :user-output :reader user-output
  43                 :documentation
  44                 "Output parameter from user, maybe stream or pathname.")
  45    (unichannel :initarg :unichannel :reader unichannel :type boolean
  46                :documentation "T if user-output is directory for individual channel output.")
  47    (formats :initarg :formats :reader formats
  48                   :documentation
  49                   "A list of output formats.")
  50    (async :initarg :async :reader async
  51                   :documentation
  52                   "Whether to use async")
  53    (last-pong :initform nil :accessor last-pong
  54                   :documentation
  55                   "utime of last pong message")
  56    (private-log :initarg :private-log :reader private-log
  57                 :documentation "Pathname of the private log file for the daemon.")
  58    (unknown-log :initarg :unknown-log :reader unknown-log
  59                 :documentation "Pathname of the log file for unknown messages.")
  60    (private-log-stream :initarg :private-log-stream :reader private-log-stream
  61                        :documentation "Stream of the private log file for the daemon.")
  62    (unknown-log-stream :initarg :unknown-log-stream :reader unknown-log-stream
  63                 :documentation "Stream of the log file for unknown messages.")
  64    (monitor-events :initform nil :accessor monitor-events
  65                    :documentation "List of events for the monitor to process.")
  66    (warning-message-utime :initform nil :accessor warning-message-utime
  67                   :documentation
  68                   "Time of last, potentially active, warning message.")))
  69
  70 (defvar *loggers* nil "List of active loggers.")
  71
  72 (defparameter *user-address-scanner*
  73   (create-scanner
  74    '(:sequence #\!
  75      (:register
  76       (:greedy-repetition 1 nil :non-whitespace-char-class)))
  77    :case-insensitive-mode t))
  78
  79 (defun find-logger-with-nick (nick)
  80   (find nick (the list *loggers*) :test #'string-equal :key #'l-nickname))
  81
  82 (defun find-logger-with-connection (conn)
  83   (find conn (the list *loggers*) :test #'eq :key #'connection))
  84
  85 (defun canonicalize-channel-name (name)
  86   (string-left-trim '(#\#) name))
  87
  88 (defun find-channel-with-name (logger name)
  89   (find name (the list (channels logger)) :test #'string-equal :key #'c-name))
  90
  91 (defun make-output-name (name year month day)
  92     (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name)
  93             year month day))
  94
  95 (defmacro with-decoding ((utime &optional zone) &body body)
  96   `(multiple-value-bind
  97     (second minute hour day-of-month month year day-of-week daylight-p zone)
  98     (decode-universal-time ,utime ,@(if zone (list zone)))
  99     (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
 100     ,@body))
 101
 102 (defun format-utime (utime &optional zone)
 103   (with-decoding (utime zone)
 104     (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
 105
 106 (defun format-date-time (utime &key stream)
 107   (with-decoding (utime)
 108     (format stream "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minute second)))
 109
 110 (defun make-output-name-utime (name utime)
 111   (with-decoding (utime 0)
 112     (make-output-name name year month day-of-month)))
 113
 114 (defgeneric write-file-header (format channel-name stream))
 115
 116 (defmethod write-file-header ((format t) channel-name stream)
 117   (declare (ignore channel-name stream))
 118   )
 119
 120 (defgeneric write-file-footer (format channel-name stream))
 121
 122 (defmethod write-file-footer ((format t) channel-name stream)
 123   (declare (ignore channel-name stream))
 124   )
 125
 126 (defun %log-file-path (output-root channel-name year month day type)
 127   (make-pathname
 128    :defaults output-root
 129    :directory (append (pathname-directory output-root)
 130                       (list
 131                        (string-left-trim '(#\#) channel-name)
 132                        (format nil "~4,'0D-~2,'0D" year month)))
 133    :name (make-output-name channel-name year month day)
 134    :type type))
 135
 136 (defgeneric log-file-path (output-root channel-name year month day format))
 137
 138 (defmethod log-file-path (output-root channel-name year month day
 139                           (format (eql :raw)))
 140   (%log-file-path output-root channel-name year month day "raw"))
 141
 142 (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
 143   (%log-file-path output-root channel-name year month day "sexp"))
 144
 145 (defmethod log-file-path (output-root channel-name year month day (format (eql :binary)))
 146   (%log-file-path output-root channel-name year month day "bin"))
 147
 148 (defmethod log-file-path (output-root channel-name year month day (format (eql :text)))
 149   (%log-file-path output-root channel-name year month day "txt"))
 150
 151 (defmethod log-file-path (output-root channel-name year month day (format string))
 152   (%log-file-path output-root channel-name year month day format))
 153
 154
 155 (defun log-file-path-utime (output-root channel-name format utime)
 156   (with-decoding (utime 0)
 157     (log-file-path output-root channel-name year month day-of-month format)))
 158
 159 (defun get-stream (channel istream)
 160   (elt (streams channel) istream))
 161
 162 (defun (setf get-stream) (value channel istream)
 163   (setf (elt (streams channel) istream) value))
 164
 165 (defun get-format (logger istream)
 166   (elt (formats logger) istream))
 167
 168 (defun get-output-name (channel istream)
 169   (elt (current-output-names channel) istream))
 170
 171 (defun (setf get-output-name) (value channel istream)
 172   (setf (elt (current-output-names channel) istream) value))
 173
 174 (defun ensure-output-stream-for-unichannel (utime logger channel istream)
 175   (let ((name (make-output-name-utime (c-name channel) utime)))
 176     (unless (string= name (get-output-name channel istream))
 177       (when (get-stream channel istream)
 178         (write-file-footer (get-format logger istream)
 179                            (c-name channel)
 180                            (get-stream channel istream))
 181         (close (get-stream channel istream)))
 182       (setf (get-output-name channel istream) name)
 183       (let ((path (log-file-path-utime (output-root channel) (c-name channel)
 184                                        (get-format logger istream) utime)))
 185         (unless (probe-file path)
 186           (ensure-directories-exist path)
 187           (setf (get-stream channel istream)
 188                 (open path :direction :output :if-exists :error
 189                       :if-does-not-exist :create))
 190           (write-file-header (get-format logger istream)
 191                              (c-name channel)
 192                               (get-stream channel istream))
 193           (close (get-stream channel istream)))
 194         (setf (get-stream channel istream)
 195               (open path :direction :output :if-exists :append
 196                     :if-does-not-exist :create))))))
 197
 198 (defun ensure-output-stream (utime logger channel istream)
 199   "Ensures that *output-stream* is correct."
 200   (cond
 201    ((streamp (user-output logger))
 202     (unless (get-stream channel istream)
 203       (setf (get-stream channel istream) (user-output logger))))
 204    ((pathnamep (user-output logger))
 205     (cond
 206      ((unichannel logger)
 207       (ensure-output-stream-for-unichannel utime logger channel istream))
 208      (t
 209       (setf (get-stream channel istream)
 210         (open (user-output logger) :direction :output :if-exists :append
 211               :if-does-not-exist :create)))))))
 212
 213 (defun user-address (msg)
 214   (let ((split (split *user-address-scanner* (raw-message-string msg)
 215                       :with-registers-p t)))
 216     (if (second split)
 217         (second split)
 218         "")))
 219
 220 (defun need-user-address? (type)
 221   (case type
 222     ((:action :privmsg :names :rpl_topic)
 223      nil)
 224     (t
 225      t)))
 226
 227 (defgeneric %output-event (format stream utime type channel source text msg
 228                            unichannel))
 229
 230 (defmethod %output-event ((format t) stream utime type channel source text
 231                           msg unichannel)
 232   (%output-event :raw stream utime type channel source text msg unichannel))
 233
 234 (defmethod %output-event ((format (eql :raw)) stream utime type channel source
 235                           text msg unichannel)
 236   (declare (ignore utime type channel source text text unichannel))
 237   (when msg
 238     (format stream "~S~%"
 239             (string-right-trim '(#\return) (raw-message-string msg)))))
 240
 241 (defconstant +posix-epoch+
 242   (encode-universal-time 0 0 0 1 1 1970 0))
 243
 244 (defun posix-time-to-utime (time)
 245   (+ time +posix-epoch+))
 246
 247 (defun last-sexp-field (type msg)
 248   (cond
 249    ((null msg)
 250     nil)
 251    ((eq type :kick)
 252     (trailing-argument msg))
 253    ((eq type :rpl_topicwhotime)
 254     (when (stringp (car (last (arguments msg))))
 255       (let ((secs (parse-integer (car (last (arguments msg))) :junk-allowed t)))
 256         (when secs
 257           (posix-time-to-utime secs)))))
 258    ((need-user-address? type)
 259     (user-address msg))))
 260
 261 (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text
 262                           msg unichannel)
 263   (with-standard-io-syntax
 264     (let ((cl:*print-case* :downcase))
 265       (if unichannel
 266           (format stream "(~S ~S ~S ~S ~S)~%" utime type source text (last-sexp-field type msg))
 267         (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel text
 268                 (last-sexp-field type msg))))))
 269
 270 (defmethod %output-event ((format (eql :text)) stream utime type channel
 271                           source text msg unichannel)
 272   (format stream "~A " (format-utime utime 0))
 273   (when (and (null unichannel) channel)
 274     (format stream "[~A] " channel))
 275
 276   (let ((user-address (when (and msg (need-user-address? type)) (user-address msg))))
 277     (case type
 278       (:privmsg
 279        (format stream "<~A> ~A" source text))
 280       (:action
 281        (format stream "*~A* ~A" source text))
 282       (:join
 283        (format stream "~A [~A] has joined ~A" source user-address channel))
 284       (:part
 285        (format stream "-!- ~A [~A] has left ~A" source user-address channel))
 286       (:nick
 287        (format stream "-!- ~A is now known as ~A" source text))
 288       (:kick
 289        (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel))
 290       (:quit
 291        (format stream "-!- ~A [~A] has quit [~A]" source user-address (if text text "")))
 292       (:mode
 293        (format stream "-!- ~A has set mode ~A"  source text))
 294       (:topic
 295        (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text))
 296       (:notice
 297        (format stream "-~A:~A- ~A" source channel text))
 298       (:daemon
 299        (format stream "-!!!- ~A" text))
 300       (:names
 301        (format stream "-!- names: ~A" text))
 302       (:rpl_topic
 303        (format stream "-!- topic: ~A" text))
 304       (t
 305        (warn "Unhandled msg type ~A." type))))
 306   (write-char #\Newline stream))
 307
 308 (defun output-event-for-a-stream (msg type channel text logger istream)
 309   (ensure-output-stream (received-time msg) logger channel istream)
 310   (%output-event  (get-format logger istream) (get-stream channel istream)
 311                   (received-time msg) type (c-name channel) (source msg) text msg
 312                   (unichannel logger))
 313   (force-output (get-stream channel istream)))
 314
 315 (defun log-daemon-message (logger fmt &rest args)
 316   (let ((text (apply #'format nil fmt args)))
 317     (add-private-log-entry logger "~A" text)
 318     ;;don't daemon messages to the logs
 319     #+ignore
 320     (dolist (channel (channels logger))
 321       (dotimes (istream (length (formats logger)))
 322         (ensure-output-stream time logger channel istream)
 323         (%output-event  (get-format logger istream)
 324                         (get-stream channel istream)
 325                         time :daemon nil nil text nil
 326                         (unichannel logger))
 327         (force-output (get-stream channel istream))))))
 328
 329 (defvar *msg*)
 330 (defun output-event (msg type channel-name &optional text)
 331   (setq *msg* msg)
 332   (dolist (logger *loggers*)
 333     (case type
 334       ((:error :server :kill)
 335        (add-private-log-entry logger "~A" (raw-message-string msg)))
 336       ((:quit :nick)
 337        ;; send to all channels that a nickname is joined
 338        (let* ((user (find-user (connection logger)
 339                                (case type
 340                                  (:nick (source msg))
 341                                  (:quit (source msg)))))
 342               (channels (when user (cl-irc::channels user))))
 343          (dolist (channel (mapcar
 344                            #'(lambda (name) (find-channel-with-name logger name))
 345                            (mapcar #'cl-irc::name channels)))
 346            (when channel
 347              (dotimes (i (length (formats logger)))
 348                (output-event-for-a-stream msg type channel text logger i))))))
 349       (t
 350        ;; msg contains channel name
 351        (let* ((channel (find-channel-with-name logger channel-name)))
 352          (when channel
 353            (dotimes (i (length (formats logger)))
 354              (output-event-for-a-stream msg type channel text logger i))))))))
 355
 356 (defun get-private-log-stream (logger)
 357   (if (and logger (private-log-stream logger))
 358       (private-log-stream logger)
 359     *standard-output*))
 360
 361 (defun get-unknown-log-stream (logger)
 362   (if (and logger (unknown-log-stream logger))
 363       (unknown-log-stream logger)
 364     *standard-output*))
 365
 366 (defun add-log-entry (stream fmt &rest args)
 367   (handler-case
 368       (progn
 369         (format-date-time (get-universal-time) :stream stream)
 370         (write-char #\space stream)
 371         (apply #'format stream fmt args)
 372         (write-char #\newline stream)
 373         (force-output stream))
 374     (error (e)
 375      (warn "Error ~A when trying to add-log-entry '~A'." e
 376            (apply #'format nil fmt args)))))
 377
 378 (defun add-private-log-entry (logger fmt &rest args)
 379   (apply #'add-log-entry
 380          (if (get-private-log-stream logger)
 381              (get-private-log-stream logger)
 382              *standard-output*)
 383          fmt args))
 384
 385 (defun privmsg-hook (msg)
 386   (let ((logger (find-logger-with-connection (connection msg)))
 387         (channel (first (arguments msg))))
 388     (cond
 389      ((equal channel (l-nickname logger))
 390       (add-private-log-entry logger "~A" (raw-message-string msg)))
 391      (t
 392       (output-event msg :privmsg channel (trailing-argument msg))))))
 393
 394 (defun action-hook (msg)
 395   (output-event msg :action (first (arguments msg))
 396                 (subseq (trailing-argument msg) 8
 397                         (- (length (trailing-argument msg)) 1))))
 398
 399 (defun nick-hook (msg)
 400   (output-event msg :nick nil (trailing-argument msg)))
 401
 402 (defun part-hook (msg)
 403   (output-event msg :part (first (arguments msg))))
 404
 405 (defun quit-hook (msg)
 406   (output-event msg :quit nil (trailing-argument msg)))
 407
 408 (defun join-hook (msg)
 409   (output-event msg :join (trailing-argument msg)))
 410
 411 (defun kick-hook (msg)
 412   (let ((logger (find-logger-with-connection (connection msg)))
 413         (channel (first (arguments msg)))
 414         (who-kicked (second (arguments msg))))
 415     (output-event msg :kick channel who-kicked)
 416     (when (string-equal (l-nickname logger) who-kicked)
 417       (add-private-log-entry
 418        logger
 419        "Logging daemon ~A has been kicked from ~A (~A)"
 420        (l-nickname logger) channel (trailing-argument msg))
 421       (daemon-sleep 1)
 422       (remove-channel-logger logger channel)
 423       (daemon-sleep 1)
 424       (add-channel-logger logger channel)
 425       (add-private-log-entry logger "Rejoined ~A" channel))))
 426
 427 (defun notice-hook (msg)
 428   (let ((logger (find-logger-with-connection (connection msg)))
 429         (channel (first (arguments msg))))
 430     (cond
 431       ((and (string-equal (source msg) "NickServ")
 432             (string-equal channel (l-nickname logger))
 433             (string-equal "owned by someone else" (trailing-argument msg)))
 434        (if logger
 435            (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger)))
 436          (add-private-log-entry logger "NickServ asks for identity with connection not found.")))
 437       ((equal channel (l-nickname logger))
 438        (add-private-log-entry logger "~A" (raw-message-string msg)))
 439       (t
 440        (output-event msg :notice channel (trailing-argument msg))))))
 441
 442 (defun ping-hook (msg)
 443   (let ((logger (find-logger-with-connection (connection msg))))
 444     (pong (connection msg) (server logger))
 445     #+debug (format *standard-output* "Sending pong to ~A~%" (server logger))))
 446
 447 (defun pong-hook (msg)
 448   (let ((logger (find-logger-with-connection (connection msg))))
 449     (setf (last-pong logger) (received-time msg))))
 450
 451 (defun topic-hook (msg)
 452   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 453
 454 (defun mode-hook (msg)
 455   (output-event msg :mode (first (arguments msg))
 456                 (format nil "~{~A~^ ~}" (cdr (arguments msg)))))
 457
 458 (defun rpl_namreply-hook (msg)
 459   (output-event msg :names (third (arguments msg))
 460                 (trailing-argument msg)))
 461
 462 (defun rpl_endofnames-hook (msg)
 463   (declare (ignore msg))
 464   ;; nothing to do for this message
 465   )
 466
 467 (defun rpl_topic-hook (msg)
 468   (output-event msg :rpl_topic (format nil "~{~A~^ ~}" (arguments msg))
 469                 (trailing-argument msg)))
 470
 471 (defun rpl_topicwhotime-hook (msg)
 472   (output-event msg :rpl_topicwhotime
 473                 (second (arguments msg))
 474                 (third (arguments msg))))
 475
 476
 477 (defun invite-hook (msg)
 478   (let ((logger (find-logger-with-connection (connection msg))))
 479     (add-private-log-entry logger "~A" (raw-message-string msg))))
 480
 481
 482 (defun make-a-channel (name formats output)
 483   (make-instance 'channel
 484                  :name name
 485                  :streams (make-array (length formats) :initial-element nil)
 486                  :output-root (when (and (pathnamep output)
 487                                          (null (pathname-name output)))
 488                                 output)
 489                  :current-output-names (make-array (length formats)
 490                                                    :initial-element nil)))
 491
 492 (defun make-channels (names formats output)
 493   (loop for i from 0 to (1- (length names))
 494         collect (make-a-channel (elt names i) formats output)))
 495
 496 (defun is-unichannel-output (user-output)
 497   "Returns T if output is setup for a single channel directory structure."
 498   (and (pathnamep user-output) (null (pathname-name user-output))))
 499
 500 (defun do-connect-and-join (nick server username realname logging-stream channels)
 501   (let ((conn (connect :nickname nick :server server
 502                        :username username :realname realname
 503                        :logging-stream logging-stream)))
 504     (mapc #'(lambda (channel) (join conn channel)) channels)
 505     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 506     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 507     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 508     (add-hook conn 'irc::irc-part-message 'part-hook)
 509     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 510     (add-hook conn 'irc::irc-join-message 'join-hook)
 511     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 512     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 513     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 514     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 515     (add-hook conn 'irc::irc-error-message 'error-hook)
 516     (add-hook conn 'irc::irc-ping-message 'ping-hook)
 517     (add-hook conn 'irc::irc-pong-message 'pong-hook)
 518     (add-hook conn 'irc::irc-kill-message 'kill-hook)
 519     (add-hook conn 'irc::irc-invite-message 'invite-hook)
 520     (add-hook conn 'irc::irc-rpl_killdone-message 'warning-hook)
 521     (add-hook conn 'irc::irc-rpl_closing-message 'warning-hook)
 522     (add-hook conn 'irc::irc-rpl_topic-message 'rpl_topic-hook)
 523     (add-hook conn 'irc::irc-rpl_namreply-message 'rpl_namreply-hook)
 524     (add-hook conn 'irc::irc-rpl_endofnames-message 'rpl_endofnames-hook)
 525     (add-hook conn 'irc::irc-rpl_topicwhotime-message 'rpl_topicwhotime-hook)
 526     conn))
 527
 528 (defmethod cl-irc::irc-message-event :around ((msg cl-irc::irc-message))
 529   (let ((result (call-next-method msg)))
 530     (typecase msg
 531       ((or irc::irc-privmsg-message irc::ctcp-action-message irc::irc-nick-message
 532         irc::irc-part-message irc::irc-quit-message irc::irc-join-message
 533         irc::irc-kick-message irc::irc-mode-message irc::irc-topic-message
 534         irc::irc-notice-message irc::irc-error-message irc::irc-ping-message
 535         irc::irc-pong-message irc::irc-kill-message irc::irc-invite-message
 536         irc::irc-rpl_killdone-message irc::irc-rpl_closing-message
 537         irc::irc-rpl_topic-message irc::irc-rpl_namreply-message
 538         irc::irc-rpl_endofnames-message irc::irc-rpl_topicwhotime-message
 539         irc::irc-rpl_motd-message irc::irc-rpl_motdstart-message
 540         irc::irc-rpl_endofmotd-message)
 541        ;; nothing to do
 542        )
 543       (t
 544        (add-log-entry
 545         (get-unknown-log-stream (find-logger-with-connection (connection msg)))
 546         "~A"
 547         (raw-message-string msg))))
 548     result))
 549
 550 (defun create-logger (nick server &key channels output password
 551                       realname username async
 552                       private-log unknown-log
 553                       (logging-stream t) (formats '(:text)))
 554   "OUTPUT may be a pathname or a stream"
 555   ;; check arguments
 556   (assert formats)
 557   (if (and channels (atom channels))
 558       (setq channels (list channels)))
 559   (if (atom formats)
 560       (setq formats (list formats)))
 561   (if (stringp output)
 562       (setq output (parse-namestring output)))
 563   (let* ((conn (do-connect-and-join nick server username realname logging-stream channels))
 564          (logger (make-instance
 565                   'logger
 566                   :connection conn
 567                   :nick nick
 568                   :password password
 569                   :server server
 570                   :channels (make-channels channels formats output)
 571                   :channel-names channels
 572                   :username username
 573                   :realname realname
 574                   :async async
 575                   :logging-stream logging-stream
 576                   :user-output output
 577                   :formats formats
 578                   :private-log private-log
 579                   :unknown-log unknown-log
 580                   :private-log-stream (when private-log
 581                                         (open private-log :direction :output
 582                                               :if-exists :append
 583                                               :if-does-not-exist :create))
 584                   :unknown-log-stream (when unknown-log
 585                                         (open unknown-log :direction :output
 586                                               :if-exists :append
 587                                               :if-does-not-exist :create))
 588                   :unichannel (is-unichannel-output output))))
 589     (unless *daemon-monitor-process*
 590       (setq *daemon-monitor-process* (cl-irc::start-process 'daemon-monitor "logger-monitor")))
 591     logger))
 592
 593 (defun start-logger (logger async)
 594   (if async
 595       (setf (handler logger)
 596         (start-background-message-handler (connection logger)))
 597       (read-message-loop (connection logger))))
 598
 599 (defun remove-logger (nick)
 600   "Quit the active connection with nick and remove from active list."
 601   (let ((logger (find-logger-with-nick nick)))
 602     (cond
 603       ((null logger)
 604        (warn
 605         "~A No active connection found with nick ~A [remove-logger].~%"
 606         (format-date-time (get-universal-time))
 607         nick)
 608        nil)
 609       (t
 610        (ignore-errors (quit-with-timeout (connection logger) ""))
 611        (ignore-errors (stop-background-message-handler (handler logger)))
 612        (sleep 1)
 613        (ignore-errors
 614          (let* ((c (connection logger))
 615                 (user (find-user c (l-nickname logger))))
 616            (when (and c user)
 617              (dolist (channel (channels logger))
 618                (remove-channel user channel)))))
 619        (ignore-errors (add-private-log-entry logger "Deleting loggers with nick of '~A' [remove-logger]." nick))
 620        (when (private-log-stream logger)
 621          (close (private-log-stream logger)))
 622        (when (unknown-log-stream logger)
 623          (close (unknown-log-stream logger)))
 624
 625        (setq *loggers*
 626              (delete nick *loggers*  :test #'string-equal :key #'l-nickname))
 627        t))))
 628
 629 (defun add-logger (nick server &key channels output (password "")
 630                                     realname username private-log unknown-log
 631                                     (logging-stream t) (async t)
 632                                     (formats '(:sexp)))
 633   (when (find-logger-with-nick nick)
 634     (add-private-log-entry (find-logger-with-nick nick)
 635                            "Closing previously active connection [add-logger].")
 636     (ignore-errors (remove-logger nick)))
 637   (add-private-log-entry nil "Calling create-logger [add-logger].~%")
 638   (let ((logger
 639          (do ((new-logger
 640                (mp:with-timeout (*timeout* nil)
 641                  (create-logger nick server :channels channels :output output
 642                                 :logging-stream logging-stream :password password
 643                                 :realname realname :username username
 644                                 :private-log private-log
 645                                 :unknown-log unknown-log
 646                                 :formats formats
 647                                 :async async))
 648                (mp:with-timeout (*timeout* nil)
 649                  (create-logger nick server :channels channels :output output
 650                                 :logging-stream logging-stream :password password
 651                                 :realname realname :username username
 652                                 :private-log private-log
 653                                 :unknown-log unknown-log
 654                                 :formats formats
 655                                 :async async))))
 656              (new-logger
 657               (progn
 658                 (add-private-log-entry nil "Acquired new logger ~A." new-logger)
 659                 new-logger))
 660            (add-private-log-entry nil "Timeout trying to create new logger [add-logger]."))))
 661     (add-private-log-entry logger "Pushing newly created logger ~A [add-logger].~%" logger)
 662     (push logger *loggers*)
 663     (start-logger logger async)
 664     logger))
 665
 666 (defun add-channel-logger (logger channel-name)
 667   (cond
 668     ((find-channel-with-name logger channel-name)
 669      (add-private-log-entry logger "Channel ~A already in logger ~A." channel-name logger)
 670      nil)
 671     (t
 672      (let ((channel (make-a-channel channel-name (formats logger) (user-output logger))))
 673        (join (connection logger) channel-name)
 674        (push channel (channels logger))
 675        (push channel-name (channel-names logger))))))
 676
 677 (defun remove-channel-logger (logger channel-name)
 678   (let ((channel (find-channel-with-name logger channel-name)))
 679     (cond
 680       (channel
 681        (part (connection logger) channel-name)
 682        (dotimes (i (length (streams channel)))
 683          (when (streamp (get-stream channel i))
 684            (close (get-stream channel i))
 685            (setf (get-stream channel i) nil)))
 686        (setf (channels logger) (delete channel-name (channels logger)
 687                                        :test #'string-equal
 688                                        :key #'c-name))
 689        (setf (channel-names logger) (delete channel-name (channel-names logger)
 690                                             :test #'string-equal))
 691        t)
 692       (t
 693        (add-private-log-entry
 694         logger "Channel name ~A not found in logger ~A." channel-name logger)
 695        nil))))
 696
 697 (defun add-hook-logger (logger class hook)
 698   (add-hook (connection logger) class hook))
 699
 700 (defun remove-hook-logger (logger class hook)
 701   (remove-hook (connection logger) class hook))
 702
 703 (defvar *warning-message-utime* nil)
 704
 705 (defun kill-hook (msg)
 706   (let ((target (second (arguments msg)))
 707         (logger (find-logger-with-connection (connection msg))))
 708     (when (and (stringp target)
 709                (string-equal target (l-nickname logger)))
 710       (setf (warning-message-utime logger) (received-time msg)))
 711     (add-private-log-entry logger "Killed by ~A" (source msg))))
 712
 713 (defun error-hook (msg)
 714   (let ((text (trailing-argument msg))
 715         (logger (find-logger-with-connection (connection msg))))
 716     (when (and (stringp text)
 717                (zerop (search (format nil "Closing Link: ~A" (l-nickname logger)) text)))
 718       (setf (warning-message-utime logger) (received-time msg)))
 719     (output-event msg :error nil (trailing-argument msg))))
 720
 721 (defun warning-hook (msg)
 722   (let ((logger (find-logger-with-connection (connection msg))))
 723     (output-event msg :server
 724                   (format nil "~{~A~^ ~} ~A)"
 725                           (arguments msg)
 726                           (trailing-argument msg)))
 727     (when logger
 728       (setf (warning-message-utime logger) (get-universal-time)))))
 729
 730 (defun daemon-sleep (seconds)
 731   #-allegro (sleep seconds)
 732   #+allegro (mp:process-sleep seconds))
 733
 734 (defun log-disconnection (logger)
 735   ;; avoid generating too many reconnect messages in the logs
 736   (when (or (null (warning-message-utime logger))
 737             (< (- (get-universal-time) (warning-message-utime logger)) 300))
 738     (log-daemon-message logger "Disconnected. Attempting reconnection.")))
 739
 740 (defun log-reconnection (logger)
 741   (log-daemon-message logger "Connection restablished."))
 742
 743 #+ignore
 744 (defun is-connected (logger)
 745   (%is-connected logger))
 746
 747
 748 (defun is-connected (logger)
 749   #-allegro (%is-connected logger)
 750   #+allegro (mp:with-timeout (*timeout* nil)
 751               (%is-connected logger)))
 752
 753 (defun quit-with-timeout (connection msg)
 754   #-allegro (quit connection msg)
 755   #+allegro (mp:with-timeout (*timeout* nil)
 756               (quit connection msg)))
 757
 758 (defun %is-connected (logger)
 759   (when (ignore-errors (ping (connection logger) (server logger)))
 760     (dotimes (i 20)
 761       (when (and (last-pong logger)
 762                  (< (- (get-universal-time) (last-pong logger)) 21))
 763         (return-from %is-connected t))
 764       (daemon-sleep 1))))
 765
 766
 767 (let (*recon-nick* *recon-server* *recon-username* *recon-realname*
 768       *recon-user-output* *recon-private-log* *recon-unknown-log*
 769       *recon-formats* *recon-async* *recon-logging-stream* *recon-channel-names*)
 770   (declare (special *recon-nick* *recon-server* *recon-username* *recon-realname*
 771                     *recon-formats* *recon-password* *recon-async*
 772                     *recon-user-output* *recon-private-log* *recon-unknown-log*
 773                     *recon-logging-stream* *recon-channel-names*))
 774
 775   (defun attempt-reconnection (logger)
 776     (when (is-connected logger)
 777       (return-from attempt-reconnection nil))
 778
 779     (log-disconnection logger)
 780     (when (connection logger)
 781       (ignore-errors (quit-with-timeout (connection logger) "Client terminated by server"))
 782       (setf *recon-nick* (l-nickname logger)
 783             *recon-server* (server logger)
 784             *recon-username* (l-username logger)
 785             *recon-realname* (l-realname logger)
 786             *recon-password* (password logger)
 787             *recon-async* (async logger)
 788             *recon-user-output* (user-output logger)
 789             *recon-private-log* (private-log logger)
 790             *recon-unknown-log* (unknown-log logger)
 791             *recon-formats* (formats logger)
 792             *recon-logging-stream* (logging-stream logger)
 793             *recon-channel-names* (channel-names logger))
 794       (ignore-errors (remove-logger logger)))
 795
 796     (let ((new-logger
 797            (ignore-errors
 798             (add-logger *recon-nick* *recon-server*
 799                         :channels *recon-channel-names*
 800                         :output *recon-user-output*
 801                         :password *recon-password*
 802                         :realname *recon-realname*
 803                         :username *recon-username*
 804                         :logging-stream *recon-logging-stream*
 805                         :private-log *recon-private-log*
 806                         :unknown-log *recon-unknown-log*
 807                         :async *recon-async*
 808                         :formats *recon-formats*))))
 809       (when new-logger
 810         (sleep 5)
 811         (when (is-connected new-logger)
 812           (log-reconnection new-logger)))))
 813   ) ;; end closure
 814
 815 (defun daemon-monitor ()
 816   "This function runs in the background and monitors the connection of the logger."
 817   ;; run forever
 818   (loop
 819    do
 820    (monitor-once)))
 821
 822 (defun monitor-once ()
 823   (dolist (logger *loggers*)
 824     (do ((warning-time (warning-message-utime logger) (warning-message-utime logger)))
 825         ((and (is-connected logger) (null warning-time)))
 826       (cond
 827         ((and warning-time (> (- (get-universal-time) warning-time) 180))
 828          ;;give up frequent checking because no disconnection despite waiting
 829          (setf (warning-message-utime logger) nil))
 830         ((not (is-connected logger))
 831          (unless warning-time
 832            (setf (warning-message-utime logger) (get-universal-time)))
 833          (attempt-reconnection logger)
 834          ;;after a succesful reconnection, the value of logger will be invalid
 835          (sleep 30)
 836          (return-from monitor-once))
 837         (t
 838          (daemon-sleep 30)))))
 839   (do ((i 0 (1+ i)))
 840       ((or (>= i 10) (some (lambda (logger) (warning-message-utime logger)) *loggers*)))
 841     (daemon-sleep 15)))
 842
 843
 844