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