From: Kevin M. Rosenberg Date: Thu, 1 Jan 2004 19:55:12 +0000 (+0000) Subject: r8451: fix background monitor X-Git-Tag: v0.9.3~36 X-Git-Url: http://git.kpe.io/?p=irc-logger.git;a=commitdiff_plain;h=b2ffa126034315878e1b863532197ae1d237fcb1 r8451: fix background monitor --- diff --git a/debian/changelog b/debian/changelog index 5f8fff5..103cd38 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-irc-logger (0.6-1) unstable; urgency=low + + * Much improved background monitor + + -- Kevin M. Rosenberg Thu, 1 Jan 2004 12:54:56 -0700 + cl-irc-logger (0.5-1) unstable; urgency=low * Added background monitor diff --git a/logger.lisp b/logger.lisp index 28c3436..15080c1 100644 --- a/logger.lisp +++ b/logger.lisp @@ -18,7 +18,7 @@ o;;; -*- Mode: Lisp -*- (defclass logger () - ((connection :initarg :connection :reader connection + ((connection :initarg :connection :accessor connection :documentation "IRC connection object.") (handler :initform nil :accessor handler :documentation "Background handler process.") @@ -46,6 +46,12 @@ o;;; -*- Mode: Lisp -*- (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") (warning-message-utime :initform nil :accessor warning-message-utime :documentation "Time of last, potentially active, warning message."))) @@ -220,9 +226,10 @@ o;;; -*- Mode: Lisp -*- (defmethod %output-event ((format (eql :raw)) stream utime type channel source text msg unichannel) - (declare (ignore utime type channel source text text unichannel )) - (format stream "~S~%" (string-right-trim '(#\return) - (raw-message-string msg)))) + (declare (ignore utime type channel source text text unichannel)) + (when msg + (format stream "~S~%" + (string-right-trim '(#\return) (raw-message-string msg))))) (defun last-sexp-field (type msg) (cond @@ -272,10 +279,12 @@ o;;; -*- Mode: Lisp -*- (format stream "-!!!- ~A" text)) (:server (format stream "-!!!- server send message ~A" source channel text)) - (:unhandled - (format stream "-!!!- ~A" text)) + (:error + (format stream "-!!!- error: ~A ~A" source text)) + (:kill + (format stream "-!!!- kill: ~A ~A" source text)) (t - (warn "Unhandled msg type ~A." type)))) + (warn "Unhandled msg type ~A." type)))) (write-char #\Newline stream)) (defun output-event-for-a-stream (msg type channel text logger istream) @@ -289,7 +298,7 @@ o;;; -*- Mode: Lisp -*- (let ((text (apply #'format nil fmt args)) (time (get-universal-time))) (dolist (channel (channels logger)) - (dotimes (istream (formats 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 @@ -301,7 +310,13 @@ o;;; -*- Mode: Lisp -*- (setq *msg* msg) (dolist (logger *loggers*) (case type + ((:error :server :kill) + ;;send to all channels + (dolist (channel (channels logger)) + (dotimes (i (length (formats logger))) + (output-event-for-a-stream msg type channel text logger i)))) ((:quit :nick) + ;; send to all channels that a nickname is joined (let* ((user (find-user (connection logger) (case type (:nick (source msg)) @@ -313,11 +328,8 @@ o;;; -*- Mode: Lisp -*- (when channel (dotimes (i (length (formats logger))) (output-event-for-a-stream msg type channel text logger i)))))) - (:server - (dolist (channel (channels logger)) - (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))) @@ -355,6 +367,15 @@ o;;; -*- Mode: Lisp -*- (warn "NickServ asks for identity with connection not found."))) (output-event msg :notice (first (arguments msg)) (trailing-argument msg)))) +(defun ping-hook (msg) + (let ((logger (find-logger-with-connection (connection msg)))) + (pong (connection msg) (server logger)) + (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))) @@ -379,9 +400,32 @@ o;;; -*- Mode: Lisp -*- (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 username realname logging-stream channels) + (let ((conn (connect :nickname nick :server server + :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-rpl_killdone-message 'warning-hook) + (add-hook conn 'irc::irc-rpl_closing-message 'warning-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) + conn)) + (defun create-logger (nick server &key channels output password - realname username + realname username async (logging-stream t) (formats '(:text))) "OUTPUT may be a pathname or a stream" ;; check arguments @@ -392,9 +436,7 @@ o;;; -*- Mode: Lisp -*- (setq formats (list formats))) (if (stringp output) (setq output (parse-namestring output))) - (let* ((conn (connect :nickname nick :server server - :username username :realname realname - :logging-stream logging-stream)) + (let* ((conn (do-connect-and-join nick server username realname logging-stream channels)) (logger (make-instance 'logger :connection conn @@ -405,24 +447,11 @@ o;;; -*- Mode: Lisp -*- :channel-names channels :username username :realname realname + :async async :logging-stream logging-stream :user-output output :formats formats :unichannel (is-unichannel-output output)))) - - (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-rpl_killdone-message 'warning-hook) - (add-hook conn 'irc::irc-rpl_closing-message 'warning-hook) (unless *daemon-monitor-process* (setq *daemon-monitor-process* (cl-irc::start-process 'daemon-monitor "logger-monitor"))) logger)) @@ -441,7 +470,7 @@ o;;; -*- Mode: Lisp -*- (warn "No active connection found with nick ~A." nick) nil) (t - (irc:quit (connection logger)) + (ignore-errors (irc:quit (connection logger) "")) (stop-background-message-handler (handler logger)) (sleep 1) (dolist (channel (channels logger)) @@ -454,14 +483,15 @@ o;;; -*- Mode: Lisp -*- (defun add-logger (nick server &key channels output (password "") realname username - (logging-stream t) (async t) (formats '(:text))) + (logging-stream t) (async t) (formats '(:text))) (when (find-logger-with-nick nick) (warn "Closing previously active connection.") - (remove-logger nick)) + (ignore-errors (remove-logger nick))) (let ((logger (create-logger nick server :channels channels :output output :logging-stream logging-stream :password password :realname realname :username username - :formats formats))) + :formats formats + :async async))) (push logger *loggers*) (start-logger logger async) logger)) @@ -505,6 +535,22 @@ o;;; -*- Mode: Lisp -*- (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 (nickname logger))) + (setf (warning-message-utime logger) (received-time msg))) + (output-event msg :kill nil (format nil "~{~A~^ ~}" (arguments msg))))) + +(defun error-hook (msg) + (let ((text (trailing-argument msg)) + (logger (find-logger-with-connection (connection msg)))) + (when (and (stringp text) + (zerop (search (format nil "Closing Link: ~A" (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 @@ -520,7 +566,8 @@ o;;; -*- Mode: Lisp -*- (defun log-disconnection (logger) ;; avoid generating too many reconnect messages in the logs - (when (< (- (get-universal-time) (warning-message-utime logger)) 300) + (when (or (null (warning-message-utime logger)) + (< (- (get-universal-time) (warning-message-utime logger)) 300)) (log-daemon-message logger "Disconnected. Attempting reconnection at ~A." (format-date-time (get-universal-time))))) @@ -528,37 +575,77 @@ o;;; -*- Mode: Lisp -*- (log-daemon-message logger "Connection restablished at ~A." (format-date-time (get-universal-time)))) -(defun attempt-reconnection (logger) - (log-disconnection logger) - (setf (connection logger) nil) - (let ((connection (connect :nickname (nickname logger) - :server (server logger) - :channel-names (channel-names logger) - :username (username logger) - :realname (realname logger) - :logging-stream (logging-stream logger)))) - (when (and connection (cl-irc::connectedp connection)) - (setf (connection logger) connection) - (log-reconnection logger) - t))) +(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)) + (sleep 1)))) + + +(let (*recon-nick* *recon-server* *recon-username* *recon-realname* + *recon-user-output* + *recon-formats* *recon-async* *recon-logging-stream* *recon-channel-names*) + (declare (special *recon-nick* *recon-server* *recon-username* *recon-realname* + *recon-formats* *recon-password* *recon-async* + *recon-user-output* + *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 (connection logger) "Client terminated by server")) + (setf *recon-nick* (nickname logger) + *recon-server* (server logger) + *recon-username* (username logger) + *recon-realname* (realname logger) + *recon-password* (password logger) + *recon-async* (async logger) + *recon-user-output* (user-output logger) + *recon-formats* (formats logger) + *recon-logging-stream* (logging-stream logger) + *recon-channel-names* (channel-names logger)) + (ignore-errors (remove-logger logger))) + + (ignore-errors + (add-logger *recon-nick* *recon-server* + :channels *recon-channel-names* + :output *recon-user-output* + :password *recon-password* + :realname *recon-realname* + :username *recon-username* + :logging-stream *recon-logging-stream* + :async *recon-async* + :formats *recon-formats*))) + ) (defun daemon-monitor () "This function runs in the background and monitors the connection of the logger." ;; run forever (do () () - (dolist (logger *loggers*) - (do ((conn (connection logger)) - (warning-time (warning-message-utime logger) (warning-message-utime logger))) - (warning-time) - (cond - ((> (- (get-universal-time) warning-time) 180) - ;;give up frequent checking because no disconnection despite waiting - (setf (warning-message-utime logger) nil)) - ((not (cl-irc::connectedp conn)) - (unless warning-time - (setf (warning-message-utime logger) (get-universal-time))) - (attempt-reconnection logger)) - (t - (daemon-sleep 30))))) - (daemon-sleep 600))) + (block main-loop + (dolist (logger *loggers*) + (do ((warning-time (warning-message-utime logger) (warning-message-utime logger))) + ((or (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 main-loop)) + (t + (daemon-sleep 30))))) + (do ((i 0 (1+ i))) + ((or (>= i 20) (some (lambda (logger) (warning-message-utime logger)) *loggers*))) + (daemon-sleep 15))))) +