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