X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=logger.lisp;h=28c3436ec1b3e043b44134ed91dd1bacd8d04a7a;hb=03c73840ef9a1ddec27b24c12610151fd6f0e0e8;hp=a1b8f5b2be15b62d2dcce262d8ff7c9674a63068;hpb=c12932912e292d322e6451aa4357c48863a8ecc0;p=irc-logger.git diff --git a/logger.lisp b/logger.lisp index a1b8f5b..28c3436 100644 --- a/logger.lisp +++ b/logger.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp -*- +o;;; -*- Mode: Lisp -*- ;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $ ;;;; ;;;; Purpose: A IRC logging bot @@ -6,6 +6,8 @@ (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,13 +20,23 @@ (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.") - (channels :initarg :channels :reader channels + (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 :documentation @@ -33,7 +45,10 @@ :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.") @@ -50,9 +65,15 @@ (defun find-logger-with-connection (conn) (find conn (the list *loggers*) :test #'eq :key #'connection)) +(defun canonicalize-channel-name (name) + (string-left-trim '(#\#) name)) + +(defun find-channel-with-name (logger name) + (find name (the list (channels logger)) :test #'string-equal :key #'name)) + (defun make-output-name (name year month day) - (format nil "~A-~4,'0D.~2,'0D.~2,'0D" - (string-left-trim '(#\#) name) year month day)) + (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name) + year month day)) (defun make-output-name-utime (name utime) (multiple-value-bind @@ -95,6 +116,9 @@ (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 @@ -156,6 +180,13 @@ (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) @@ -163,7 +194,7 @@ (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) @@ -193,13 +224,21 @@ (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) @@ -207,7 +246,7 @@ (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)) @@ -222,13 +261,19 @@ (:kick (format stream "-!- ~A [~A] has been kicked from ~A" source user-address channel)) (:quit - (format stream "-!- ~A [~A] has quit [~A]" source user-address text)) + (format stream "-!- ~A [~A] has quit [~A]" source user-address (if text text ""))) (:mode (format stream "-!- ~A has set mode ~A" source text)) (:topic (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)) @@ -240,16 +285,40 @@ (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-name (the list (channels logger)) - :test #'string-equal :key #'name))) + (let* ((channel (find-channel-with-name logger channel-name))) (when channel (dotimes (i (length (formats logger))) (output-event-for-a-stream msg type channel text logger i)))))))) @@ -269,7 +338,7 @@ (output-event msg :part (first (arguments msg)))) (defun quit-hook (msg) - (output-event msg :quit (trailing-argument msg))) + (output-event msg :quit nil (trailing-argument msg))) (defun join-hook (msg) (output-event msg :join (trailing-argument msg))) @@ -290,37 +359,41 @@ (output-event msg :topic (first (arguments msg)) (trailing-argument msg))) (defun mode-hook (msg) - (output-event msg :mode (first (arguments msg)))) - + (output-event msg :mode (first (arguments msg)) + (format nil "~{~A~^ ~}" (cdr (arguments msg))))) + +(defun make-a-channel (name formats output) + (make-instance 'channel + :name name + :streams (make-array (length formats) :initial-element nil) + :output-root (when (and (pathnamep output) + (null (pathname-name output))) + output) + :current-output-names (make-array (length formats) + :initial-element nil))) + (defun make-channels (names formats output) (loop for i from 0 to (1- (length names)) - collect - (make-instance 'channel - :name (nth i names) - :streams (make-array (length formats) :initial-element nil) - :output-root (when (and (pathnamep output) - (null (pathname-name output))) - output) - :current-output-names (make-array (length formats) - :initial-element nil)))) + collect (make-a-channel (elt names i) formats 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 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 channels) (assert formats) - (if (atom channels) + (if (and channels (atom channels)) (setq channels (list channels))) (if (atom formats) (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 @@ -329,6 +402,10 @@ :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)))) @@ -344,14 +421,19 @@ (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 quit-logger (nick) +(defun remove-logger (nick) "Quit the active connection with nick and remove from active list." (let ((logger (find-logger-with-nick nick))) (cond @@ -360,30 +442,123 @@ nil) (t (irc:quit (connection logger)) + (stop-background-message-handler (handler logger)) (sleep 1) (dolist (channel (channels logger)) - (dotimes (i (length (streams channel))) - (when (streamp (get-stream channel i)) - (close (get-stream channel i)) - (setf (get-stream channel i) nil)))) + (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.") - (quit-logger nick)) + (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) logger)) +(defun add-channel-logger (logger channel-name) + (cond + ((find-channel-with-name logger channel-name) + (warn "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 #'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." + 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 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)))