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