+(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)))
+
+