X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=logger.lisp;h=28c3436ec1b3e043b44134ed91dd1bacd8d04a7a;hb=03c73840ef9a1ddec27b24c12610151fd6f0e0e8;hp=7baa2415d8a227a1a54e0c781d53bac067d76e7b;hpb=d2506e00f04b101331b460806d23cb47364ebec5;p=irc-logger.git diff --git a/logger.lisp b/logger.lisp index 7baa241..28c3436 100644 --- a/logger.lisp +++ b/logger.lisp @@ -6,6 +6,8 @@ o;;; -*- Mode: Lisp -*- (in-package irc-logger) +(defvar *daemon-monitor-process* nil "Process of background monitor.") + (defclass channel () ((name :initarg :name :reader name :documentation "Name of channel.") @@ -18,12 +20,22 @@ o;;; -*- Mode: Lisp -*- (defclass logger () ((connection :initarg :connection :reader connection :documentation "IRC connection object.") + (handler :initform nil :accessor handler + :documentation "Background handler process.") (nick :initarg :nick :reader 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.") + (channel-names :initarg :channel-names :accessor channel-names + :documentation "List of channel names.") + (realname :initarg :realname :reader realname + :documentation "Realname for cl-irc") + (username :initarg :username :reader 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 @@ -33,7 +45,10 @@ o;;; -*- Mode: Lisp -*- :documentation "T if user-output is directory for individual channel output.") (formats :initarg :formats :reader formats :documentation - "A list of output formats."))) + "A list of output formats.") + (warning-message-utime :initform nil :accessor warning-message-utime + :documentation + "Time of last, potentially active, warning message."))) (defvar *loggers* nil "List of active loggers.") @@ -101,6 +116,9 @@ o;;; -*- Mode: Lisp -*- (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) (multiple-value-bind @@ -162,6 +180,13 @@ o;;; -*- Mode: Lisp -*- (setf (get-stream channel istream) (open (user-output logger) :direction :output :if-exists :append))))))) +(defun format-date-time (utime) + (multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time utime) + (declare (ignore day-of-week daylight-p zone)) + (format nil "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minute second))) + (defun format-utime (utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) @@ -169,7 +194,7 @@ o;;; -*- Mode: Lisp -*- (declare (ignore day-of-month month year day-of-week daylight-p zone)) (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))) -(defun format-utime-short(utime) +(defun format-utime-short (utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) @@ -199,13 +224,21 @@ o;;; -*- Mode: Lisp -*- (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string msg)))) +(defun last-sexp-field (type msg) + (cond + ((null msg) + nil) + ((eq type :kick) + (trailing-argument msg)) + ((need-user-address? type) + (user-address msg)))) + (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text msg unichannel) (if unichannel - (format stream "(~S ~S ~S ~S ~S)~%" utime type source text - (when (need-user-address? type) (user-address msg))) - (format stream "(~S ~S ~S ~S ~S ~S)~%" utime type source channel - text (when (need-user-address? type) (user-address msg))))) + (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) @@ -213,7 +246,7 @@ o;;; -*- Mode: Lisp -*- (when (and (null unichannel) channel) (format stream "[~A] " channel)) - (let ((user-address (when (need-user-address? type) (user-address msg)))) + (let ((user-address (when (and msg (need-user-address? type)) (user-address msg)))) (case type (:privmsg (format stream "<~A> ~A" source text)) @@ -235,6 +268,12 @@ o;;; -*- Mode: Lisp -*- (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)) + (:server + (format stream "-!!!- server send message ~A" source channel text)) + (:unhandled + (format stream "-!!!- ~A" text)) (t (warn "Unhandled msg type ~A." type)))) (write-char #\Newline stream)) @@ -246,13 +285,38 @@ o;;; -*- Mode: Lisp -*- (unichannel logger)) (force-output (get-stream channel istream))) +(defun log-daemon-message (logger fmt &rest args) + (let ((text (apply #'format nil fmt args)) + (time (get-universal-time))) + (dolist (channel (channels logger)) + (dotimes (istream (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 ((:quit :nick) - (dolist (channel (channels logger)) - (dotimes (i (length (formats logger))) - (output-event-for-a-stream msg type channel text logger i)))) + (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)))))) + (:server + (dolist (channel (channels logger)) + (dotimes (i (length (formats logger))) + (output-event-for-a-stream msg type channel text logger i)))) (t (let* ((channel (find-channel-with-name logger channel-name))) (when channel @@ -317,7 +381,8 @@ o;;; -*- Mode: Lisp -*- (and (pathnamep user-output) (null (pathname-name user-output)))) (defun create-logger (nick server &key channels output password - (logging-stream t) (formats '(:text))) + realname username + (logging-stream t) (formats '(:text))) "OUTPUT may be a pathname or a stream" ;; check arguments (assert formats) @@ -327,7 +392,8 @@ o;;; -*- Mode: Lisp -*- (setq formats (list formats))) (if (stringp output) (setq output (parse-namestring output))) - (let* ((conn (connect :nickname nick :server server + (let* ((conn (connect :nickname nick :server server + :username username :realname realname :logging-stream logging-stream)) (logger (make-instance 'logger @@ -336,6 +402,10 @@ o;;; -*- Mode: Lisp -*- :password password :server server :channels (make-channels channels formats output) + :channel-names channels + :username username + :realname realname + :logging-stream logging-stream :user-output output :formats formats :unichannel (is-unichannel-output output)))) @@ -351,11 +421,16 @@ o;;; -*- Mode: Lisp -*- (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)) (defun start-logger (logger async) (if async - (start-background-message-handler (connection logger)) + (setf (handler logger) + (start-background-message-handler (connection logger))) (read-message-loop (connection logger)))) (defun remove-logger (nick) @@ -367,20 +442,25 @@ o;;; -*- Mode: Lisp -*- nil) (t (irc:quit (connection logger)) + (stop-background-message-handler (handler logger)) (sleep 1) (dolist (channel (channels logger)) - (remove-channel logger (name channel))) + (let ((c (connection logger))) + (when c + (ignore-errors (remove-channel c (find-channel c (name channel))))))) (setq *loggers* (delete nick *loggers* :test #'string-equal :key #'nickname)) t)))) (defun add-logger (nick server &key channels output (password "") + realname username (logging-stream t) (async t) (formats '(:text))) (when (find-logger-with-nick nick) (warn "Closing previously active connection.") (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))) (push logger *loggers*) (start-logger logger async) @@ -394,7 +474,8 @@ o;;; -*- Mode: Lisp -*- (t (let ((channel (make-a-channel channel-name (formats logger) (user-output logger)))) (join (connection logger) channel-name) - (push channel (channels logger)))))) + (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))) @@ -408,6 +489,8 @@ o;;; -*- Mode: Lisp -*- (setf (channels logger) (delete channel-name (channels logger) :test #'string-equal :key #'name)) + (setf (channel-names logger) (delete channel-name (channel-names logger) + :test #'string-equal)) t) (t (warn "Channel name ~A not found in logger ~A." @@ -419,3 +502,63 @@ o;;; -*- Mode: Lisp -*- (defun remove-hook-logger (logger class hook) (remove-hook (connection logger) class hook)) + +(defvar *warning-message-utime* nil) + +(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 (< (- (get-universal-time) (warning-message-utime logger)) 300) + (log-daemon-message logger "Disconnected. Attempting reconnection at ~A." + (format-date-time (get-universal-time))))) + +(defun log-reconnection (logger) + (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 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)))