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