logger.lisp

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