r8451: fix background monitor

diff --git a/debian/changelog b/debian/changelog
index 5f8fff5a22abf92af3df972cd5c92d0e0ff4c5e1..103cd38828c7fd703756a2fd4efe542f16bcdade 100644 (file)
--- 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 <kmr@debian.org>  Thu,  1 Jan 2004 12:54:56 -0700
+

 cl-irc-logger (0.5-1) unstable; urgency=low
 
   * Added background monitor
 cl-irc-logger (0.5-1) unstable; urgency=low
 
   * Added background monitor

diff --git a/logger.lisp b/logger.lisp
index 28c3436ec1b3e043b44134ed91dd1bacd8d04a7a..15080c17c81de67b6524ecf23f3eb2f1bb11a332 100644 (file)
--- a/logger.lisp
+++ b/logger.lisp
@@ -18,7 +18,7 @@ o;;;  -*- Mode: Lisp -*-
 
    
 (defclass logger ()
 
    
 (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.")
               :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.")
    (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.")))
    (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)
 
 (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
 
 (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))
        (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
       (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)
   (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))
   (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
        (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
   (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)
       ((:quit :nick)

+       ;; send to all channels that a nickname is joined

        (let* ((user (find-user (connection logger)
                               (case type
                                 (:nick (source msg))
        (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))))))
           (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
       (t

+       ;; msg contains channel name

        (let* ((channel (find-channel-with-name logger channel-name)))
         (when channel
           (dotimes (i (length (formats logger)))
        (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))))
 
            (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)))
 
 (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 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
 (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
                                       (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)))
       (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
         (logger (make-instance
                  'logger
                  :connection conn


@@ -405,24 +447,11 @@ o;;;  -*- Mode: Lisp -*-
                  :channel-names channels
                  :username username
                  :realname realname
                  :channel-names channels
                  :username username
                  :realname realname

+                 :async async

                  :logging-stream logging-stream
                  :user-output output
                  :formats formats
                  :unichannel (is-unichannel-output output))))
                  :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))
     (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
        (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))
        (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
 
 (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.")
   (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
   (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))
     (push logger *loggers*)
     (start-logger logger async)
     logger))


@@ -505,6 +535,22 @@ o;;;  -*- Mode: Lisp -*-
 
 (defvar *warning-message-utime* nil)
 
 
 (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 
 (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
 
 (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)))))
 
     (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))))
 
   (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 ()
       ()
 
 (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)))))
+