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 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    (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   (let ((end (- (length (trailing-argument msg)) 1)))
 400     ;; end has been as low as 7
 401     (when (< end 8)
 402       (warn "End is less than 8: `$A'." msg))
 403     (output-event msg :action (first (arguments msg))
 404                   (subseq (trailing-argument msg) (min 8 end)
 405                           (- (length (trailing-argument msg)) 1)))))
 406
 407 (defun nick-hook (msg)
 408   (output-event msg :nick nil (trailing-argument msg)))
 409
 410 (defun part-hook (msg)
 411   (output-event msg :part (first (arguments msg))))
 412
 413 (defun quit-hook (msg)
 414   (output-event msg :quit nil (trailing-argument msg)))
 415
 416 (defun join-hook (msg)
 417   (output-event msg :join (trailing-argument msg)))
 418
 419 (defun kick-hook (msg)
 420   (let ((logger (find-logger-with-connection (connection msg)))
 421         (channel (first (arguments msg)))
 422         (who-kicked (second (arguments msg))))
 423     (output-event msg :kick channel who-kicked)
 424     (when (string-equal (l-nickname logger) who-kicked)
 425       (add-private-log-entry
 426        logger
 427        "Logging daemon ~A has been kicked from ~A (~A)"
 428        (l-nickname logger) channel (trailing-argument msg))
 429       (daemon-sleep 5)
 430       (remove-channel-logger logger channel)
 431       (daemon-sleep 10)
 432       (add-channel-logger logger channel)
 433       (add-private-log-entry logger "Rejoined ~A" channel))))
 434
 435 (defun notice-hook (msg)
 436   (let ((logger (find-logger-with-connection (connection msg)))
 437         (channel (first (arguments msg))))
 438     (cond
 439       ((and (string-equal (source msg) "NickServ")
 440             (string-equal channel (l-nickname logger))
 441             (string-equal "owned by someone else" (trailing-argument msg)))
 442        (if logger
 443            (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger)))
 444          (add-private-log-entry logger "NickServ asks for identity with connection not found.")))
 445       ((equal channel (l-nickname logger))
 446        (add-private-log-entry logger "~A" (raw-message-string msg)))
 447       (t
 448        (output-event msg :notice channel (trailing-argument msg))))))
 449
 450 (defun ping-hook (msg)
 451   (let ((logger (find-logger-with-connection (connection msg))))
 452     (pong (connection msg) (server logger))
 453     #+debug (format *standard-output* "Sending pong to ~A~%" (server logger))))
 454
 455 (defun pong-hook (msg)
 456   (let ((logger (find-logger-with-connection (connection msg))))
 457     (setf (last-pong logger) (received-time msg))))
 458
 459 (defun topic-hook (msg)
 460   (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
 461
 462 (defun mode-hook (msg)
 463   (output-event msg :mode (first (arguments msg))
 464                 (format nil "~{~A~^ ~}" (cdr (arguments msg)))))
 465
 466 (defun rpl_namreply-hook (msg)
 467   (output-event msg :names (third (arguments msg))
 468                 (trailing-argument msg)))
 469
 470 (defun rpl_endofnames-hook (msg)
 471   (declare (ignore msg))
 472   ;; nothing to do for this message
 473   )
 474
 475 (defun rpl_topic-hook (msg)
 476   (output-event msg :rpl_topic (format nil "~{~A~^ ~}" (arguments msg))
 477                 (trailing-argument msg)))
 478
 479 (defun rpl_topicwhotime-hook (msg)
 480   (output-event msg :rpl_topicwhotime
 481                 (second (arguments msg))
 482                 (third (arguments msg))))
 483
 484
 485 (defun invite-hook (msg)
 486   (let ((logger (find-logger-with-connection (connection msg))))
 487     (add-private-log-entry logger "~A" (raw-message-string msg))))
 488
 489
 490 (defun make-a-channel (name formats output)
 491   (make-instance 'log-channel
 492                  :name name
 493                  :streams (make-array (length formats) :initial-element nil)
 494                  :output-root (when (and (pathnamep output)
 495                                          (null (pathname-name output)))
 496                                 output)
 497                  :current-output-names (make-array (length formats)
 498                                                    :initial-element nil)))
 499
 500 (defun make-channels (names formats output)
 501   (loop for i from 0 to (1- (length names))
 502         collect (make-a-channel (elt names i) formats output)))
 503
 504 (defun is-unichannel-output (user-output)
 505   "Returns T if output is setup for a single channel directory structure."
 506   (and (pathnamep user-output) (null (pathname-name user-output))))
 507
 508 (defun do-connect-and-join (nick server username realname logging-stream channels)
 509   (let ((conn (connect :nickname nick :server server
 510                        :username username :realname realname
 511                        :logging-stream logging-stream)))
 512     (mapc #'(lambda (channel) (join conn channel)) channels)
 513     (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook)
 514     (add-hook conn 'irc::ctcp-action-message 'action-hook)
 515     (add-hook conn 'irc::irc-nick-message 'nick-hook)
 516     (add-hook conn 'irc::irc-part-message 'part-hook)
 517     (add-hook conn 'irc::irc-quit-message 'quit-hook)
 518     (add-hook conn 'irc::irc-join-message 'join-hook)
 519     (add-hook conn 'irc::irc-kick-message 'kick-hook)
 520     (add-hook conn 'irc::irc-mode-message 'mode-hook)
 521     (add-hook conn 'irc::irc-topic-message 'topic-hook)
 522     (add-hook conn 'irc::irc-notice-message 'notice-hook)
 523     (add-hook conn 'irc::irc-error-message 'error-hook)
 524     (add-hook conn 'irc::irc-ping-message 'ping-hook)
 525     (add-hook conn 'irc::irc-pong-message 'pong-hook)
 526     (add-hook conn 'irc::irc-kill-message 'kill-hook)
 527     (add-hook conn 'irc::irc-invite-message 'invite-hook)
 528     (add-hook conn 'irc::irc-rpl_killdone-message 'warning-hook)
 529     (add-hook conn 'irc::irc-rpl_closing-message 'warning-hook)
 530     (add-hook conn 'irc::irc-rpl_topic-message 'rpl_topic-hook)
 531     (add-hook conn 'irc::irc-rpl_namreply-message 'rpl_namreply-hook)
 532     (add-hook conn 'irc::irc-rpl_endofnames-message 'rpl_endofnames-hook)
 533     (add-hook conn 'irc::irc-rpl_topicwhotime-message 'rpl_topicwhotime-hook)
 534     conn))
 535
 536 (defmethod cl-irc::irc-message-event :around ((msg cl-irc::irc-message))
 537   (let ((result (call-next-method msg)))
 538     (typecase msg
 539       ((or irc::irc-privmsg-message irc::ctcp-action-message irc::irc-nick-message
 540         irc::irc-part-message irc::irc-quit-message irc::irc-join-message
 541         irc::irc-kick-message irc::irc-mode-message irc::irc-topic-message
 542         irc::irc-notice-message irc::irc-error-message irc::irc-ping-message
 543         irc::irc-pong-message irc::irc-kill-message irc::irc-invite-message
 544         irc::irc-rpl_killdone-message irc::irc-rpl_closing-message
 545         irc::irc-rpl_topic-message irc::irc-rpl_namreply-message
 546         irc::irc-rpl_endofnames-message irc::irc-rpl_topicwhotime-message
 547         irc::irc-rpl_motd-message irc::irc-rpl_motdstart-message
 548         irc::irc-rpl_endofmotd-message)
 549        ;; nothing to do
 550        )
 551       (t
 552        (add-log-entry
 553         (get-unknown-log-stream (find-logger-with-connection (connection msg)))
 554         "~A"
 555         (raw-message-string msg))))
 556     result))
 557
 558 (defun create-logger (nick server &key channels output password
 559                       realname username async
 560                       private-log unknown-log
 561                       (logging-stream t) (formats '(:text)))
 562   "OUTPUT may be a pathname or a stream"
 563   ;; check arguments
 564   (assert formats)
 565   (if (and channels (atom channels))
 566       (setq channels (list channels)))
 567   (if (atom formats)
 568       (setq formats (list formats)))
 569   (if (stringp output)
 570       (setq output (parse-namestring output)))
 571   (let* ((conn (do-connect-and-join nick server username realname logging-stream channels))
 572          (logger (make-instance
 573                   'logger
 574                   :connection conn
 575                   :nick nick
 576                   :password password
 577                   :server server
 578                   :channels (make-channels channels formats output)
 579                   :channel-names channels
 580                   :username username
 581                   :realname realname
 582                   :async async
 583                   :logging-stream logging-stream
 584                   :user-output output
 585                   :formats formats
 586                   :private-log private-log
 587                   :unknown-log unknown-log
 588                   :private-log-stream (when private-log
 589                                         (open private-log :direction :output
 590                                               :if-exists :append
 591                                               :if-does-not-exist :create))
 592                   :unknown-log-stream (when unknown-log
 593                                         (open unknown-log :direction :output
 594                                               :if-exists :append
 595                                               :if-does-not-exist :create))
 596                   :unichannel (is-unichannel-output output))))
 597     (unless *daemon-monitor-process*
 598       (setq *daemon-monitor-process* (cl-irc::start-process 'daemon-monitor "logger-monitor")))
 599     logger))
 600
 601 (defun start-logger (logger async)
 602   (if async
 603       (setf (handler logger)
 604         (start-background-message-handler (connection logger)))
 605       (read-message-loop (connection logger))))
 606
 607 (defun remove-logger (nick)
 608   "Quit the active connection with nick and remove from active list."
 609   (let ((logger (find-logger-with-nick nick)))
 610     (cond
 611       ((null logger)
 612        (warn
 613         "~A No active connection found with nick ~A [remove-logger].~%"
 614         (format-date-time (get-universal-time))
 615         nick)
 616        nil)
 617       (t
 618        (ignore-errors (quit-with-timeout (connection logger) ""))
 619        (ignore-errors (stop-background-message-handler (handler logger)))
 620        (sleep 1)
 621        (ignore-errors
 622          (let* ((c (connection logger))
 623                 (user (find-user c (l-nickname logger))))
 624            (when (and c user)
 625              (dolist (channel (channels logger))
 626                (remove-channel user channel)))))
 627        (ignore-errors (add-private-log-entry logger "Deleting loggers with nick of '~A' [remove-logger]." nick))
 628        (when (private-log-stream logger)
 629          (close (private-log-stream logger)))
 630        (when (unknown-log-stream logger)
 631          (close (unknown-log-stream logger)))
 632
 633        (setq *loggers*
 634              (delete nick *loggers*  :test #'string-equal :key #'l-nickname))
 635        t))))
 636
 637 (defun add-logger (nick server &key channels output (password "")
 638                                     realname username private-log unknown-log
 639                                     (logging-stream t) (async t)
 640                                     (formats '(:sexp)))
 641   (when (find-logger-with-nick nick)
 642     (add-private-log-entry (find-logger-with-nick nick)
 643                            "Closing previously active connection [add-logger].")
 644     (ignore-errors (remove-logger nick)))
 645   (add-private-log-entry nil "Calling create-logger [add-logger].~%")
 646   (let ((logger
 647          (do ((new-logger
 648                (mp:with-timeout (*timeout* nil)
 649                  (create-logger nick server :channels channels :output output
 650                                 :logging-stream logging-stream :password password
 651                                 :realname realname :username username
 652                                 :private-log private-log
 653                                 :unknown-log unknown-log
 654                                 :formats formats
 655                                 :async async))
 656                (mp:with-timeout (*timeout* nil)
 657                  (create-logger nick server :channels channels :output output
 658                                 :logging-stream logging-stream :password password
 659                                 :realname realname :username username
 660                                 :private-log private-log
 661                                 :unknown-log unknown-log
 662                                 :formats formats
 663                                 :async async))))
 664              (new-logger
 665               (progn
 666                 (add-private-log-entry nil "Acquired new logger ~A." new-logger)
 667                 new-logger))
 668            (add-private-log-entry nil "Timeout trying to create new logger [add-logger]."))))
 669     (add-private-log-entry logger "Pushing newly created logger ~A [add-logger].~%" logger)
 670     (push logger *loggers*)
 671     (start-logger logger async)
 672     logger))
 673
 674 (defun add-channel-logger (logger channel-name)
 675   (cond
 676     ((find-channel-with-name logger channel-name)
 677      (add-private-log-entry logger "Channel ~A already in logger ~A." channel-name 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 #'c-name))
 697        (setf (channel-names logger) (delete channel-name (channel-names logger)
 698                                             :test #'string-equal))
 699        t)
 700       (t
 701        (add-private-log-entry
 702         logger "Channel name ~A not found in logger ~A." channel-name logger)
 703        nil))))
 704
 705 (defun add-hook-logger (logger class hook)
 706   (add-hook (connection logger) class hook))
 707
 708 (defun remove-hook-logger (logger class hook)
 709   (remove-hook (connection logger) class hook))
 710
 711 (defvar *warning-message-utime* nil)
 712
 713 (defun kill-hook (msg)
 714   (let ((target (second (arguments msg)))
 715         (logger (find-logger-with-connection (connection msg))))
 716     (when (and (stringp target)
 717                (string-equal target (l-nickname logger)))
 718       (setf (warning-message-utime logger) (received-time msg)))
 719     (add-private-log-entry logger "Killed by ~A" (source msg))))
 720
 721 (defun error-hook (msg)
 722   (let ((text (trailing-argument msg))
 723         (logger (find-logger-with-connection (connection msg))))
 724     (when (and (stringp text)
 725                (eql 0 (search (format nil "Closing Link: ~A"
 726                                       (l-nickname logger)) text)))
 727       (setf (warning-message-utime logger) (received-time msg)))
 728     (output-event msg :error nil (trailing-argument msg))))
 729
 730 (defun warning-hook (msg)
 731   (let ((logger (find-logger-with-connection (connection msg))))
 732     (output-event msg :server
 733                   (format nil "~{~A~^ ~} ~A)"
 734                           (arguments msg)
 735                           (trailing-argument msg)))
 736     (when logger
 737       (setf (warning-message-utime logger) (get-universal-time)))))
 738
 739 (defun daemon-sleep (seconds)
 740   #-allegro (sleep seconds)
 741   #+allegro (mp:process-sleep seconds))
 742
 743 (defun log-disconnection (logger)
 744   ;; avoid generating too many reconnect messages in the logs
 745   (when (or (null (warning-message-utime logger))
 746             (< (- (get-universal-time) (warning-message-utime logger)) 300))
 747     (log-daemon-message logger "Disconnected. Attempting reconnection.")))
 748
 749 (defun log-reconnection (logger)
 750   (log-daemon-message logger "Connection restablished."))
 751
 752 #+ignore
 753 (defun is-connected (logger)
 754   (%is-connected logger))
 755
 756
 757 (defun is-connected (logger)
 758   #-allegro (%is-connected logger)
 759   #+allegro (mp:with-timeout (*timeout* nil)
 760               (%is-connected logger)))
 761
 762 (defun quit-with-timeout (connection msg)
 763   #-allegro (quit connection msg)
 764   #+allegro (mp:with-timeout (*timeout* nil)
 765               (quit connection msg)))
 766
 767 (defun %is-connected (logger)
 768   (when (ignore-errors (ping (connection logger) (server logger)))
 769     (dotimes (i 20)
 770       (when (and (last-pong logger)
 771                  (< (- (get-universal-time) (last-pong logger)) 21))
 772         (return-from %is-connected t))
 773       (daemon-sleep 1))))
 774
 775
 776 (let (*recon-nick* *recon-server* *recon-username* *recon-realname*
 777       *recon-user-output* *recon-private-log* *recon-unknown-log*
 778       *recon-formats* *recon-async* *recon-logging-stream* *recon-channel-names*)
 779   (declare (special *recon-nick* *recon-server* *recon-username* *recon-realname*
 780                     *recon-formats* *recon-password* *recon-async*
 781                     *recon-user-output* *recon-private-log* *recon-unknown-log*
 782                     *recon-logging-stream* *recon-channel-names*))
 783
 784   (defun attempt-reconnection (logger)
 785     (when (is-connected logger)
 786       (return-from attempt-reconnection nil))
 787
 788     (log-disconnection logger)
 789     (when (connection logger)
 790       (ignore-errors (quit-with-timeout (connection logger) "Client terminated by server"))
 791       (setf *recon-nick* (l-nickname logger)
 792             *recon-server* (server logger)
 793             *recon-username* (l-username logger)
 794             *recon-realname* (l-realname logger)
 795             *recon-password* (password logger)
 796             *recon-async* (async logger)
 797             *recon-user-output* (user-output logger)
 798             *recon-private-log* (private-log logger)
 799             *recon-unknown-log* (unknown-log logger)
 800             *recon-formats* (formats logger)
 801             *recon-logging-stream* (logging-stream logger)
 802             *recon-channel-names* (channel-names logger))
 803       (ignore-errors (remove-logger logger)))
 804
 805     (let ((new-logger
 806            (ignore-errors
 807             (add-logger *recon-nick* *recon-server*
 808                         :channels *recon-channel-names*
 809                         :output *recon-user-output*
 810                         :password *recon-password*
 811                         :realname *recon-realname*
 812                         :username *recon-username*
 813                         :logging-stream *recon-logging-stream*
 814                         :private-log *recon-private-log*
 815                         :unknown-log *recon-unknown-log*
 816                         :async *recon-async*
 817                         :formats *recon-formats*))))
 818       (when new-logger
 819         (sleep 5)
 820         (when (is-connected new-logger)
 821           (log-reconnection new-logger)))))
 822   ) ;; end closure
 823
 824 (defun daemon-monitor ()
 825   "This function runs in the background and monitors the connection of the logger."
 826   ;; run forever
 827   (loop
 828    do
 829    (monitor-once)))
 830
 831 (defun monitor-once ()
 832   (dolist (logger *loggers*)
 833     (do ((warning-time (warning-message-utime logger) (warning-message-utime logger)))
 834         ((and (is-connected logger) (null warning-time)))
 835       (cond
 836         ((and warning-time (> (- (get-universal-time) warning-time) 180))
 837          ;;give up frequent checking because no disconnection despite waiting
 838          (setf (warning-message-utime logger) nil))
 839         ((not (is-connected logger))
 840          (unless warning-time
 841            (setf (warning-message-utime logger) (get-universal-time)))
 842          (attempt-reconnection logger)
 843          ;;after a succesful reconnection, the value of logger will be invalid
 844          (sleep 30)
 845          (return-from monitor-once))
 846         (t
 847          (daemon-sleep 30)))))
 848   (do ((i 0 (1+ i)))
 849       ((or (>= i 10) (some (lambda (logger) (warning-message-utime logger)) *loggers*)))
 850     (daemon-sleep 15)))
 851
 852
 853