cl-irc-logger-0.9.4/0000755000175000017500000000000010716671322013171 5ustar kevinkevincl-irc-logger-0.9.4/LICENSE0000644000175000017500000000173110667175452014210 0ustar kevinkevinCopyright (c) 2003 Kevin Rosenberg Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) cl-irc-logger-0.9.4/irc-logger.asd0000644000175000017500000000056210667175452015727 0ustar kevinkevin;;;; -*- Mode: Lisp -*- ;;;; ASDF definition for irc-logger ;;;; $Id: irc-logger.asd,v 1.1 2003/12/14 16:10:29 krosenberg Exp $ (in-package cl-user) (defpackage irc-logger-system (:use :cl :asdf)) (in-package irc-logger-system) (defsystem irc-logger :depends-on (cl-irc cl-ppcre) :components ((:file "package") (:file "logger" :depends-on ("package")))) cl-irc-logger-0.9.4/package.lisp0000644000175000017500000000064210667175452015467 0ustar kevinkevin;;;; -*- Mode: Lisp -*- ;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $ ;;;; (in-package #:cl-user) (defpackage #:irc-logger (:use #:common-lisp #:irc #:cl-ppcre) (:export #:add-logger #:remove-logger #:add-channel-logger #:remove-channel-logger #:log-file-path #:add-hook-logger #:remove-hook-logger #:*loggers*)) cl-irc-logger-0.9.4/logger.lisp0000644000175000017500000010632010716671304015343 0ustar kevinkevin;;; -*- Mode: Lisp -*- ;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $ ;;;; ;;;; Purpose: A IRC logging bot ;;;; Author: Kevin Rosenberg (in-package #:irc-logger) (defvar *daemon-monitor-process* nil "Process of background monitor.") (defparameter *timeout* 120) (defclass log-channel () ((name :initarg :name :reader c-name :documentation "Name of channel.") (streams :initarg :streams :reader streams :documentation "List of output streams.") (output-root :initarg :output-root :reader output-root) (current-output-names :initarg :current-output-names :accessor current-output-names))) (defclass logger () ((connection :initarg :connection :accessor connection :documentation "IRC connection object.") (handler :initform nil :accessor handler :documentation "Background handler process.") (nick :initarg :nick :reader l-nickname :documentation "Nickname of the bot.") (password :initarg :password :reader password :documentation "Nickname's nickserver password.") (server :initarg :server :reader server :documentation "Connected IRC server.") (port :initarg :port :reader port :documentation "Connected IRC server's port.") (channel-names :initarg :channel-names :accessor channel-names :documentation "List of channel names.") (realname :initarg :realname :reader l-realname :documentation "Realname for cl-irc") (username :initarg :username :reader l-username :documentation "Username for cl-irc") (logging-stream :initarg :logging-stream :reader logging-stream :documentation "logging-stream for cl-irc.") (channels :initarg :channels :accessor channels :documentation "List of channels.") (user-output :initarg :user-output :reader user-output :documentation "Output parameter from user, maybe stream or pathname.") (unichannel :initarg :unichannel :reader unichannel :type boolean :documentation "T if user-output is directory for individual channel output.") (formats :initarg :formats :reader formats :documentation "A list of output formats.") (async :initarg :async :reader async :documentation "Whether to use async") (last-pong :initform nil :accessor last-pong :documentation "utime of last pong message") (private-log :initarg :private-log :reader private-log :documentation "Pathname of the private log file for the daemon.") (unknown-log :initarg :unknown-log :reader unknown-log :documentation "Pathname of the log file for unknown messages.") (private-log-stream :initarg :private-log-stream :reader private-log-stream :documentation "Stream of the private log file for the daemon.") (unknown-log-stream :initarg :unknown-log-stream :reader unknown-log-stream :documentation "Stream of the log file for unknown messages.") (monitor-events :initform nil :accessor monitor-events :documentation "List of events for the monitor to process.") (warning-message-utime :initform nil :accessor warning-message-utime :documentation "Time of last, potentially active, warning message."))) (defmethod print-object ((obj logger) stream) (print-unreadable-object (obj stream :type t :identity t) (format stream "~A" (l-nickname obj)))) (defvar *loggers* nil "List of active loggers.") (defparameter *user-address-scanner* (create-scanner '(:sequence #\! (:register (:greedy-repetition 1 nil :non-whitespace-char-class))) :case-insensitive-mode t)) (defun find-logger-with-nick (nick) (find nick (the list *loggers*) :test #'string-equal :key #'l-nickname)) (defun find-logger-with-connection (conn) (find conn (the list *loggers*) :test #'eq :key #'connection)) (defun canonicalize-channel-name (name) (string-left-trim '(#\#) name)) (defun find-channel-with-name (logger name) (find name (the list (channels logger)) :test #'string-equal :key #'c-name)) (defun make-output-name (name year month day) (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name) year month day)) (defmacro with-decoding ((utime &optional zone) &body body) `(multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time ,utime ,@(if zone (list zone))) (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) ,@body)) (defun format-utime (utime &optional zone) (with-decoding (utime zone) (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))) (defun format-date-time (utime &key stream) (with-decoding (utime) (format stream "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minute second))) (defun make-output-name-utime (name utime) (with-decoding (utime 0) (make-output-name name year month day-of-month))) (defgeneric write-file-header (format channel-name stream)) (defmethod write-file-header ((format t) channel-name stream) (declare (ignore channel-name stream)) ) (defgeneric write-file-footer (format channel-name stream)) (defmethod write-file-footer ((format t) channel-name stream) (declare (ignore channel-name stream)) ) (defun %log-file-path (output-root channel-name year month day type) (make-pathname :defaults output-root :directory (append (pathname-directory output-root) (list (string-left-trim '(#\#) channel-name) (format nil "~4,'0D-~2,'0D" year month))) :name (make-output-name channel-name year month day) :type type)) (defgeneric log-file-path (output-root channel-name year month day format)) (defmethod log-file-path (output-root channel-name year month day (format (eql :raw))) (%log-file-path output-root channel-name year month day "raw")) (defmethod log-file-path (output-root channel-name year month day (format (eql :sexp))) (%log-file-path output-root channel-name year month day "sexp")) (defmethod log-file-path (output-root channel-name year month day (format (eql :binary))) (%log-file-path output-root channel-name year month day "bin")) (defmethod log-file-path (output-root channel-name year month day (format (eql :text))) (%log-file-path output-root channel-name year month day "txt")) (defmethod log-file-path (output-root channel-name year month day (format string)) (%log-file-path output-root channel-name year month day format)) (defun log-file-path-utime (output-root channel-name format utime) (with-decoding (utime 0) (log-file-path output-root channel-name year month day-of-month format))) (defun get-stream (channel istream) (elt (streams channel) istream)) (defun (setf get-stream) (value channel istream) (setf (elt (streams channel) istream) value)) (defun get-format (logger istream) (elt (formats logger) istream)) (defun get-output-name (channel istream) (elt (current-output-names channel) istream)) (defun (setf get-output-name) (value channel istream) (setf (elt (current-output-names channel) istream) value)) (defun ensure-output-stream-for-unichannel (utime logger channel istream) (let ((name (make-output-name-utime (c-name channel) utime))) (unless (string= name (get-output-name channel istream)) (when (get-stream channel istream) (write-file-footer (get-format logger istream) (c-name channel) (get-stream channel istream)) (close (get-stream channel istream))) (setf (get-output-name channel istream) name) (let ((path (log-file-path-utime (output-root channel) (c-name channel) (get-format logger istream) utime))) (unless (probe-file path) (ensure-directories-exist path) (setf (get-stream channel istream) (open path :direction :output :if-exists :error :if-does-not-exist :create)) (write-file-header (get-format logger istream) (c-name channel) (get-stream channel istream)) (close (get-stream channel istream))) (setf (get-stream channel istream) (open path :direction :output :if-exists :append :if-does-not-exist :create)))))) (defun ensure-output-stream (utime logger channel istream) "Ensures that *output-stream* is correct." (cond ((streamp (user-output logger)) (unless (get-stream channel istream) (setf (get-stream channel istream) (user-output logger)))) ((pathnamep (user-output logger)) (cond ((unichannel logger) (ensure-output-stream-for-unichannel utime logger channel istream)) (t (setf (get-stream channel istream) (open (user-output logger) :direction :output :if-exists :append :if-does-not-exist :create))))))) (defun user-address (msg) (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) (if (second split) (second split) ""))) (defun need-user-address? (type) (case type ((:action :privmsg :names :rpl_topic) nil) (t t))) (defgeneric %output-event (format stream utime type channel source text msg unichannel)) (defmethod %output-event ((format t) stream utime type channel source text msg unichannel) (%output-event :raw stream utime type channel source text msg unichannel)) (defmethod %output-event ((format (eql :raw)) stream utime type channel source text msg unichannel) (declare (ignore utime type channel source text text unichannel)) (when msg (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string msg))))) (defconstant +posix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) (defun posix-time-to-utime (time) (+ time +posix-epoch+)) (defun last-sexp-field (type msg) (cond ((null msg) nil) ((eq type :kick) (trailing-argument msg)) ((eq type :rpl_topicwhotime) (when (stringp (car (last (arguments msg)))) (let ((secs (parse-integer (car (last (arguments msg))) :junk-allowed t))) (when secs (posix-time-to-utime secs))))) ((need-user-address? type) (user-address msg)))) (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text msg unichannel) (with-standard-io-syntax (let ((cl:*print-case* :downcase)) (if unichannel (format stream "(~S ~S ~S ~S ~S)~%" utime type source text (last-sexp-field type msg)) (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel text (last-sexp-field type msg)))))) (defmethod %output-event ((format (eql :text)) stream utime type channel source text msg unichannel) (format stream "~A " (format-utime utime 0)) (when (and (null unichannel) channel) (format stream "[~A] " channel)) (let ((user-address (when (and msg (need-user-address? type)) (user-address msg)))) (case type (:privmsg (format stream "<~A> ~A" source text)) (:action (format stream "*~A* ~A" source text)) (:join (format stream "~A [~A] has joined ~A" source user-address channel)) (:part (format stream "-!- ~A [~A] has left ~A" source user-address channel)) (:nick (format stream "-!- ~A is now known as ~A" source text)) (:kick (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel)) (:quit (format stream "-!- ~A [~A] has quit [~A]" source user-address (if text text ""))) (:mode (format stream "-!- ~A has set mode ~A" source text)) (:topic (format stream "-!- ~A changed the topic of ~A to: ~A" source channel text)) (:notice (format stream "-~A:~A- ~A" source channel text)) (:daemon (format stream "-!!!- ~A" text)) (:names (format stream "-!- names: ~A" text)) (:rpl_topic (format stream "-!- topic: ~A" text)) (t (warn "Unhandled msg type ~A." type)))) (write-char #\Newline stream)) (defun output-event-for-a-stream (msg type channel text logger istream) (ensure-output-stream (received-time msg) logger channel istream) (%output-event (get-format logger istream) (get-stream channel istream) (received-time msg) type (c-name channel) (source msg) text msg (unichannel logger)) (force-output (get-stream channel istream))) (defun log-daemon-message (logger fmt &rest args) (let ((text (apply #'format nil fmt args))) (add-private-log-entry logger "~A" text) ;;don't daemon messages to the logs #+ignore (dolist (channel (channels logger)) (dotimes (istream (length (formats logger))) (ensure-output-stream time logger channel istream) (%output-event (get-format logger istream) (get-stream channel istream) time :daemon nil nil text nil (unichannel logger)) (force-output (get-stream channel istream)))))) (defvar *msg*) (defun output-event (msg type channel-name &optional text) (setq *msg* msg) (dolist (logger *loggers*) (case type ((:error :server :kill) (add-private-log-entry logger "~A" (raw-message-string msg))) ((:quit :nick) ;; send to all channels that a nickname is joined (let* ((user (find-user (connection logger) (case type (:nick (source msg)) (:quit (source msg))))) (channels (when user (cl-irc::channels user)))) (dolist (channel (mapcar #'(lambda (name) (find-channel-with-name logger name)) (mapcar #'cl-irc::name channels))) (when channel (dotimes (i (length (formats logger))) (output-event-for-a-stream msg type channel text logger i)))))) (t ;; msg contains channel name (let* ((channel (find-channel-with-name logger channel-name))) (when channel (dotimes (i (length (formats logger))) (output-event-for-a-stream msg type channel text logger i)))))))) (defun get-private-log-stream (logger) (if (and logger (private-log-stream logger)) (private-log-stream logger) *standard-output*)) (defun get-unknown-log-stream (logger) (if (and logger (unknown-log-stream logger)) (unknown-log-stream logger) *standard-output*)) (defun add-log-entry (stream fmt &rest args) (handler-case (progn (format-date-time (get-universal-time) :stream stream) (write-char #\space stream) (apply #'format stream fmt args) (write-char #\newline stream) (force-output stream)) (error (e) (warn "Error ~A when trying to add-log-entry '~A'." e (apply #'format nil fmt args))))) (defun add-private-log-entry (logger fmt &rest args) (apply #'add-log-entry (if (and logger (get-private-log-stream logger)) (get-private-log-stream logger) *standard-output*) fmt args)) (defun privmsg-hook (msg) (let ((logger (find-logger-with-connection (connection msg))) (channel (first (arguments msg)))) (cond ((equal channel (l-nickname logger)) (add-private-log-entry logger "~A" (raw-message-string msg))) (t (output-event msg :privmsg channel (trailing-argument msg)))))) (defun action-hook (msg) (let ((end (- (length (trailing-argument msg)) 1))) ;; end has been as low as 7 (when (< end 8) (warn "End is less than 8: `~A'." msg)) (output-event msg :action (first (arguments msg)) (subseq (trailing-argument msg) (min 8 end) (- (length (trailing-argument msg)) 1))))) (defun nick-hook (msg) (output-event msg :nick nil (trailing-argument msg))) (defun part-hook (msg) (output-event msg :part (first (arguments msg)))) (defun quit-hook (msg) (output-event msg :quit nil (trailing-argument msg))) (defun join-hook (msg) (output-event msg :join (trailing-argument msg))) (defun kick-hook (msg) (let ((logger (find-logger-with-connection (connection msg))) (channel (first (arguments msg))) (who-kicked (second (arguments msg)))) (output-event msg :kick channel who-kicked) (when (string-equal (l-nickname logger) who-kicked) (add-private-log-entry logger "Logging daemon ~A has been kicked from ~A (~A)" (l-nickname logger) channel (trailing-argument msg)) (daemon-sleep 5) (remove-channel-logger logger channel) (daemon-sleep 10) (add-channel-logger logger channel) (add-private-log-entry logger "Rejoined ~A" channel)))) (defun notice-hook (msg) (let ((logger (find-logger-with-connection (connection msg))) (channel (first (arguments msg)))) (cond ((and (string-equal (source msg) "NickServ") (string-equal channel (l-nickname logger)) (string-equal "owned by someone else" (trailing-argument msg))) (if logger (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger))) (add-private-log-entry logger "NickServ asks for identity with connection not found."))) ((equal channel (l-nickname logger)) (add-private-log-entry logger "~A" (raw-message-string msg))) (t (output-event msg :notice channel (trailing-argument msg)))))) (defun ping-hook (msg) (let ((logger (find-logger-with-connection (connection msg)))) (pong (connection msg) (server logger)) #+debug (format *standard-output* "Sending pong to ~A~%" (server logger)))) (defun pong-hook (msg) (let ((logger (find-logger-with-connection (connection msg)))) (setf (last-pong logger) (received-time msg)))) (defun topic-hook (msg) (output-event msg :topic (first (arguments msg)) (trailing-argument msg))) (defun mode-hook (msg) (output-event msg :mode (first (arguments msg)) (format nil "~{~A~^ ~}" (cdr (arguments msg))))) (defun rpl_namreply-hook (msg) (output-event msg :names (third (arguments msg)) (trailing-argument msg))) (defun rpl_endofnames-hook (msg) (declare (ignore msg)) ;; nothing to do for this message ) (defun rpl_topic-hook (msg) (output-event msg :rpl_topic (format nil "~{~A~^ ~}" (arguments msg)) (trailing-argument msg))) (defun rpl_topicwhotime-hook (msg) (output-event msg :rpl_topicwhotime (second (arguments msg)) (third (arguments msg)))) (defun invite-hook (msg) (let ((logger (find-logger-with-connection (connection msg)))) (add-private-log-entry logger "~A" (raw-message-string msg)))) (defun make-a-channel (name formats output) (make-instance 'log-channel :name name :streams (make-array (length formats) :initial-element nil) :output-root (when (and (pathnamep output) (null (pathname-name output))) output) :current-output-names (make-array (length formats) :initial-element nil))) (defun make-channels (names formats output) (loop for i from 0 to (1- (length names)) collect (make-a-channel (elt names i) formats output))) (defun is-unichannel-output (user-output) "Returns T if output is setup for a single channel directory structure." (and (pathnamep user-output) (null (pathname-name user-output)))) (defun do-connect-and-join (nick server port username realname logging-stream channels) (unless port (setq port 6667)) (let ((conn (connect :nickname nick :server server :port port :username username :realname realname :logging-stream logging-stream))) (mapc #'(lambda (channel) (join conn channel)) channels) (add-hook conn 'irc::irc-privmsg-message 'privmsg-hook) (add-hook conn 'irc::ctcp-action-message 'action-hook) (add-hook conn 'irc::irc-nick-message 'nick-hook) (add-hook conn 'irc::irc-part-message 'part-hook) (add-hook conn 'irc::irc-quit-message 'quit-hook) (add-hook conn 'irc::irc-join-message 'join-hook) (add-hook conn 'irc::irc-kick-message 'kick-hook) (add-hook conn 'irc::irc-mode-message 'mode-hook) (add-hook conn 'irc::irc-topic-message 'topic-hook) (add-hook conn 'irc::irc-notice-message 'notice-hook) (add-hook conn 'irc::irc-error-message 'error-hook) (add-hook conn 'irc::irc-ping-message 'ping-hook) (add-hook conn 'irc::irc-pong-message 'pong-hook) (add-hook conn 'irc::irc-kill-message 'kill-hook) (add-hook conn 'irc::irc-invite-message 'invite-hook) (add-hook conn 'irc::irc-rpl_killdone-message 'warning-hook) (add-hook conn 'irc::irc-rpl_closing-message 'warning-hook) (add-hook conn 'irc::irc-rpl_topic-message 'rpl_topic-hook) (add-hook conn 'irc::irc-rpl_namreply-message 'rpl_namreply-hook) (add-hook conn 'irc::irc-rpl_endofnames-message 'rpl_endofnames-hook) (add-hook conn 'irc::irc-rpl_topicwhotime-message 'rpl_topicwhotime-hook) conn)) (defmethod cl-irc::irc-message-event :around (connection (msg cl-irc::irc-message)) (let ((result (call-next-method connection msg))) (typecase msg ((or irc::irc-privmsg-message irc::ctcp-action-message irc::irc-nick-message irc::irc-part-message irc::irc-quit-message irc::irc-join-message irc::irc-kick-message irc::irc-mode-message irc::irc-topic-message irc::irc-notice-message irc::irc-error-message irc::irc-ping-message irc::irc-pong-message irc::irc-kill-message irc::irc-invite-message irc::irc-rpl_killdone-message irc::irc-rpl_closing-message irc::irc-rpl_topic-message irc::irc-rpl_namreply-message irc::irc-rpl_endofnames-message irc::irc-rpl_topicwhotime-message irc::irc-rpl_motd-message irc::irc-rpl_motdstart-message irc::irc-rpl_endofmotd-message) ;; nothing to do ) (t (add-log-entry (get-unknown-log-stream (find-logger-with-connection connection)) "~A" (raw-message-string msg)))) result)) (defun create-logger (nick server &key (port 6667) channels output password realname username async private-log unknown-log (logging-stream t) (formats '(:text))) "OUTPUT may be a pathname or a stream" ;; check arguments (assert formats) (if (and channels (atom channels)) (setq channels (list channels))) (if (atom formats) (setq formats (list formats))) (if (stringp output) (setq output (parse-namestring output))) (let* ((conn (do-connect-and-join nick server port username realname logging-stream channels)) (logger (make-instance 'logger :connection conn :nick nick :password password :server server :port port :channels (make-channels channels formats output) :channel-names channels :username username :realname realname :async async :logging-stream logging-stream :user-output output :formats formats :private-log private-log :unknown-log unknown-log :private-log-stream (when private-log (open private-log :direction :output :if-exists :append :if-does-not-exist :create)) :unknown-log-stream (when unknown-log (open unknown-log :direction :output :if-exists :append :if-does-not-exist :create)) :unichannel (is-unichannel-output output)))) (unless *daemon-monitor-process* (setq *daemon-monitor-process* (cl-irc::start-process 'daemon-monitor "logger-monitor"))) logger)) (defun start-logger (logger async) (if async (setf (handler logger) (start-background-message-handler (connection logger))) (read-message-loop (connection logger)))) (defun remove-logger (nick) "Quit the active connection with nick and remove from active list." (let ((logger (find-logger-with-nick nick))) (cond ((null logger) (warn "~A No active connection found with nick ~A [remove-logger].~%" (format-date-time (get-universal-time)) nick) nil) (t (ignore-errors (quit-with-timeout (connection logger) "")) (ignore-errors (stop-background-message-handler (handler logger))) (sleep 1) (ignore-errors (let* ((c (connection logger)) (user (find-user c (l-nickname logger)))) (when (and c user) (dolist (channel (channels logger)) (remove-channel user channel))))) (ignore-errors (add-private-log-entry logger "Deleting loggers with nick of '~A' [remove-logger]." nick)) (when (private-log-stream logger) (close (private-log-stream logger))) (when (unknown-log-stream logger) (close (unknown-log-stream logger))) (setq *loggers* (delete nick *loggers* :test #'string-equal :key #'l-nickname)) t)))) (defun add-logger (nick server &key (port 6667) channels output (password "") realname username private-log unknown-log (logging-stream t) (async t) (formats '(:sexp))) (when (find-logger-with-nick nick) (add-private-log-entry (find-logger-with-nick nick) "Closing previously active connection [add-logger].") (ignore-errors (remove-logger nick))) (add-private-log-entry nil "Calling create-logger [add-logger].~%") (let ((logger (do ((new-logger (#+allegro mp:with-timeout #+allegro (*timeout* nil) #+sbcl sb-ext:with-timeout #+sbcl *timeout* #+lispworks progn (create-logger nick server :port port :channels channels :output output :logging-stream logging-stream :password password :realname realname :username username :private-log private-log :unknown-log unknown-log :formats formats :async async)) (#+allegro mp:with-timeout #+allegro (*timeout* nil) #+sbcl sb-ext:with-timeout #+sbcl *timeout* #+lispworks progn (create-logger nick server :port port :channels channels :output output :logging-stream logging-stream :password password :realname realname :username username :private-log private-log :unknown-log unknown-log :formats formats :async async)))) (new-logger (progn (add-private-log-entry nil "Acquired new logger ~A." new-logger) new-logger)) (add-private-log-entry nil "Timeout trying to create new logger [add-logger].")))) (add-private-log-entry logger "Pushing newly created logger ~A [add-logger].~%" logger) (push logger *loggers*) (start-logger logger async) logger)) (defun add-channel-logger (logger channel-name) (cond ((find-channel-with-name logger channel-name) (add-private-log-entry logger "Channel ~A already in logger ~A." channel-name logger) nil) (t (let ((channel (make-a-channel channel-name (formats logger) (user-output logger)))) (join (connection logger) channel-name) (push channel (channels logger)) (push channel-name (channel-names logger)))))) (defun remove-channel-logger (logger channel-name) (let ((channel (find-channel-with-name logger channel-name))) (cond (channel (part (connection logger) channel-name) (dotimes (i (length (streams channel))) (when (streamp (get-stream channel i)) (close (get-stream channel i)) (setf (get-stream channel i) nil))) (setf (channels logger) (delete channel-name (channels logger) :test #'string-equal :key #'c-name)) (setf (channel-names logger) (delete channel-name (channel-names logger) :test #'string-equal)) t) (t (add-private-log-entry logger "Channel name ~A not found in logger ~A." channel-name logger) nil)))) (defun add-hook-logger (logger class hook) (add-hook (connection logger) class hook)) (defun remove-hook-logger (logger class hook) (remove-hook (connection logger) class hook)) (defvar *warning-message-utime* nil) (defun kill-hook (msg) (let ((target (second (arguments msg))) (logger (find-logger-with-connection (connection msg)))) (when (and (stringp target) (string-equal target (l-nickname logger))) (setf (warning-message-utime logger) (received-time msg))) (add-private-log-entry logger "Killed by ~A" (source msg)))) (defun error-hook (msg) (let ((text (trailing-argument msg)) (logger (find-logger-with-connection (connection msg)))) (when (and (stringp text) (eql 0 (search (format nil "Closing Link: ~A" (l-nickname logger)) text))) (setf (warning-message-utime logger) (received-time msg))) (output-event msg :error nil (trailing-argument msg)))) (defun warning-hook (msg) (let ((logger (find-logger-with-connection (connection msg)))) (output-event msg :server (format nil "~{~A~^ ~} ~A)" (arguments msg) (trailing-argument msg))) (when logger (setf (warning-message-utime logger) (get-universal-time))))) (defun daemon-sleep (seconds) #-allegro (sleep seconds) #+allegro (mp:process-sleep seconds)) (defun log-disconnection (logger) ;; avoid generating too many reconnect messages in the logs (when (or (null (warning-message-utime logger)) (< (- (get-universal-time) (warning-message-utime logger)) 300)) (log-daemon-message logger "Disconnected. Attempting reconnection."))) (defun log-reconnection (logger) (log-daemon-message logger "Connection restablished.")) #+ignore (defun is-connected (logger) (%is-connected logger)) (defun is-connected (logger) #-allegro (%is-connected logger) #+allegro (mp:with-timeout (*timeout* nil) (%is-connected logger))) (defun quit-with-timeout (connection msg) #-allegro (quit connection msg) #+allegro (mp:with-timeout (*timeout* nil) (quit connection msg))) (defun %is-connected (logger) (when (ignore-errors (ping (connection logger) (server logger))) (dotimes (i 20) (when (and (last-pong logger) (< (- (get-universal-time) (last-pong logger)) 21)) (return-from %is-connected t)) (daemon-sleep 1)))) (let (*recon-nick* *recon-server* *recon-port* *recon-username* *recon-realname* *recon-user-output* *recon-private-log* *recon-unknown-log* *recon-formats* *recon-async* *recon-logging-stream* *recon-channel-names*) (declare (special *recon-nick* *recon-server* *recon-port* *recon-username* *recon-realname* *recon-formats* *recon-password* *recon-async* *recon-user-output* *recon-private-log* *recon-unknown-log* *recon-logging-stream* *recon-channel-names*)) (defun attempt-reconnection (logger) (when (is-connected logger) (return-from attempt-reconnection nil)) (log-disconnection logger) (when (connection logger) (ignore-errors (quit-with-timeout (connection logger) "Client terminated by server")) (setf *recon-nick* (l-nickname logger) *recon-server* (server logger) *recon-port* (port logger) *recon-username* (l-username logger) *recon-realname* (l-realname logger) *recon-password* (password logger) *recon-async* (async logger) *recon-user-output* (user-output logger) *recon-private-log* (private-log logger) *recon-unknown-log* (unknown-log logger) *recon-formats* (formats logger) *recon-logging-stream* (logging-stream logger) *recon-channel-names* (channel-names logger)) (ignore-errors (remove-logger logger))) (do ((new-logger nil)) (new-logger) (setq new-logger (ignore-errors (add-logger *recon-nick* *recon-server* :port *recon-port* :channels *recon-channel-names* :output *recon-user-output* :password *recon-password* :realname *recon-realname* :username *recon-username* :logging-stream *recon-logging-stream* :private-log *recon-private-log* :unknown-log *recon-unknown-log* :async *recon-async* :formats *recon-formats*))) (cond (new-logger (sleep 240) (cond ((is-connected new-logger) (log-reconnection new-logger)) (t (log-daemon-message new-logger "Newly added logger is not connected. Removing connection and will re-attempt.") (ignore-errors (remove-logger new-logger)) (sleep 60) (setq new-logger nil)))) (t (log-daemon-message nil "Got NIL for new logger. Waiting and retrying.") (sleep 20))))) ) ;; end closure (defun daemon-monitor () "This function runs in the background and monitors the connection of the logger." ;; run forever (loop do (monitor-once))) (defun monitor-once () (dolist (logger *loggers*) (do ((warning-time (warning-message-utime logger) (warning-message-utime logger))) ((and (is-connected logger) (null warning-time))) (cond ((and warning-time (> (- (get-universal-time) warning-time) 180)) ;;give up frequent checking because no disconnection despite waiting (setf (warning-message-utime logger) nil)) ((not (is-connected logger)) (unless warning-time (setf (warning-message-utime logger) (get-universal-time))) (attempt-reconnection logger) ;;after a succesful reconnection, the value of logger will be invalid (sleep 30) (return-from monitor-once)) (t (daemon-sleep 30))))) (do ((i 0 (1+ i))) ((or (>= i 10) (some (lambda (logger) (warning-message-utime logger)) *loggers*))) (daemon-sleep 15)))