(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.")
(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.")))
(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
(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)
(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
(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))
(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)))
(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 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
(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
: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))
(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))
(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))
(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 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
"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)))))
+