logger.lisp

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