X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=logger.lisp;h=3bb165f1560f7145d07c48cada914db38b582331;hb=d289ec60467cae9601d4eb2f1b150037bf586fb9;hp=d35708b6c540e3783c9ffabd35011a7fb190833f;hpb=2db886103084235214cc42e42364da110e42afff;p=irc-logger.git diff --git a/logger.lisp b/logger.lisp index d35708b..3bb165f 100644 --- a/logger.lisp +++ b/logger.lisp @@ -91,11 +91,23 @@ (format nil "~A-~4,'0D.~2,'0D.~2,'0D" (canonicalize-channel-name name) year month day)) +(defmacro with-decoding ((utime &optional zone) &body body) + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + ,@body)) + +(defun format-utime (utime &optional zone) + (with-decoding (utime zone) + (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))) + +(defun format-date-time (utime &key stream) + (with-decoding (utime) + (format stream "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minute second))) + (defun make-output-name-utime (name utime) - (multiple-value-bind - (second minute hour day-of-month month year day-of-week daylight-p zone) - (decode-universal-time utime) - (declare (ignore second minute hour day-of-week daylight-p zone)) + (with-decoding (utime 0) (make-output-name name year month day-of-month))) (defgeneric write-file-header (format channel-name stream)) @@ -137,11 +149,8 @@ (defun log-file-path-utime (output-root channel-name format utime) - (multiple-value-bind - (second minute hour day month year day-of-week daylight-p zone) - (decode-universal-time utime) - (declare (ignore second minute hour day-of-week daylight-p zone)) - (log-file-path output-root channel-name year month day format))) + (with-decoding (utime 0) + (log-file-path output-root channel-name year month day-of-month format))) (defun get-stream (channel istream) (elt (streams channel) istream)) @@ -197,27 +206,6 @@ (open (user-output logger) :direction :output :if-exists :append :if-does-not-exist :create))))))) -(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) - (decode-universal-time utime) - (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) - (multiple-value-bind - (second minute hour day-of-month month year day-of-week daylight-p zone) - (decode-universal-time utime) - (declare (ignore second day-of-month month year day-of-week daylight-p zone)) - (format nil "~2,'0D:~2,'0D" hour minute))) - (defun user-address (msg) (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) @@ -268,16 +256,16 @@ (defmethod %output-event ((format (eql :sexp)) stream utime type channel source text msg unichannel) - (let ((*print-circle* nil) - (*print-pretty* nil)) - (if unichannel - (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))))) + (with-standard-io-syntax + (let ((cl:*print-case* :downcase)) + (if unichannel + (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) - (format stream "~A " (format-utime utime)) + (format stream "~A " (format-utime utime 0)) (when (and (null unichannel) channel) (format stream "[~A] " channel)) @@ -321,11 +309,10 @@ (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))) - (format (get-private-log-stream logger) - "~A ~A~%" (format-date-time time) text) - (force-output (get-private-log-stream logger)) + (let ((text (apply #'format nil fmt args))) + (add-private-log-entry logger "~A" text) + ;;don't daemon messages to the logs + #+ignore (dolist (channel (channels logger)) (dotimes (istream (length (formats logger))) (ensure-output-stream time logger channel istream) @@ -341,11 +328,7 @@ (dolist (logger *loggers*) (case type ((:error :server :kill) - (format (get-private-log-stream logger) - "~A ~A~%" - (format-date-time (received-time msg)) - (raw-message-string msg)) - (force-output (get-private-log-stream logger))) + (add-private-log-entry logger "~A" (raw-message-string msg))) ((:quit :nick) ;; send to all channels that a nickname is joined (let* ((user (find-user (connection logger) @@ -367,22 +350,36 @@ (output-event-for-a-stream msg type channel text logger i)))))))) (defun get-private-log-stream (logger) - (or (private-log-stream logger) *standard-output*)) + (if (and logger (private-log-stream logger)) + (private-log-stream logger) + *standard-output*)) (defun get-unknown-log-stream (logger) - (or (unknown-log-stream logger) *standard-output*)) + (if (and logger (unknown-log-stream logger)) + (unknown-log-stream logger) + *standard-output*)) + +(defun add-log-entry (stream fmt &rest args) + (handler-case + (progn + (format-date-time (get-universal-time) :stream stream) + (write-char #\space stream) + (apply #'format stream fmt args) + (write-char #\newline stream) + (force-output stream)) + (error (e) + (warn "Error ~A when trying to add-log-entry '~A'." e + (apply #'format nil fmt args))))) + +(defun add-private-log-entry (logger fmt &rest args) + (apply #'add-log-entry (get-private-log-stream logger) fmt args)) (defun privmsg-hook (msg) (let ((logger (find-logger-with-connection (connection msg))) (channel (first (arguments msg)))) (cond ((equal channel (nickname logger)) - (format - (get-private-log-stream logger) - "~A ~A~%" - (format-date-time (get-universal-time)) - (raw-message-string msg)) - (force-output (get-private-log-stream logger))) + (add-private-log-entry logger "~A" (raw-message-string msg))) (t (output-event msg :privmsg channel (trailing-argument msg)))))) @@ -409,24 +406,14 @@ (who-kicked (second (arguments msg)))) (output-event msg :kick channel who-kicked) (when (string-equal (nickname logger) who-kicked) - (format - (get-private-log-stream logger) - "~A Logging daemon ~A has been kicked from ~A (~A)~%" - (format-date-time (received-time msg)) - (nickname logger) - channel - (trailing-argument msg)) - (force-output (get-private-log-stream logger)) + (add-private-log-entry + "Logging daemon ~A has been kicked from ~A (~A)" + (nickname logger) channel (trailing-argument msg)) (daemon-sleep 1) (remove-channel-logger logger channel) (daemon-sleep 1) (add-channel-logger logger channel) - (format - (get-private-log-stream logger) - "~A Rejoined ~A~%" - (format-date-time (received-time msg)) - channel) - (force-output (get-private-log-stream logger))))) + (add-private-log-entry logger "Rejoined ~A" channel)))) (defun notice-hook (msg) (let ((logger (find-logger-with-connection (connection msg))) @@ -437,17 +424,9 @@ (string-equal "owned by someone else" (trailing-argument msg))) (if logger (privmsg (connection msg) (source msg) (format nil "IDENTIFY ~A" (password logger))) - (format - (get-private-log-stream logger) - "~A NickServ asks for identity with connection not found.~%" - (format-date-time (received-time msg))))) + (add-private-log-entry logger "NickServ asks for identity with connection not found."))) ((equal channel (nickname logger)) - (format - (get-private-log-stream logger) - "~A ~A~%" - (format-date-time (get-universal-time)) - (raw-message-string msg)) - (force-output (get-private-log-stream logger))) + (add-private-log-entry logger "~A" (raw-message-string msg))) (t (output-event msg :notice channel (trailing-argument msg)))))) @@ -488,12 +467,7 @@ (defun invite-hook (msg) (let ((logger (find-logger-with-connection (connection msg)))) - (format - (get-private-log-stream logger) - "~A ~A~%" - (format-date-time (get-universal-time)) - (raw-message-string msg)) - (force-output (get-private-log-stream logger)))) + (add-private-log-entry logger "~A" (raw-message-string msg)))) (defun make-a-channel (name formats output) @@ -558,13 +532,9 @@ ;; nothing to do ) (t - (let ((logger (find-logger-with-connection (connection msg)))) - (format (get-unknown-log-stream - (find-logger-with-connection (connection msg))) - "~A ~A~%" - (format-date-time (received-time msg )) - (raw-message-string msg)) - (force-output (get-unknown-log-stream logger))))) + (add-log-entry + (get-unknown-log-stream (find-logger-with-connection (connection msg))) + (raw-message-string msg)))) result)) (defun create-logger (nick server &key channels output password @@ -648,10 +618,8 @@ (logging-stream t) (async t) (formats '(:sexp))) (when (find-logger-with-nick nick) - (format - (get-private-log-stream (find-logger-with-nick nick)) - "~A Closing previously active connection [add-logger].~%" - (format-date-time (get-universal-time))) + (add-private-log-entry (find-logger-with-nick nick) + "Closing previously active connection [add-logger].") (ignore-errors (remove-logger nick))) (let ((logger (create-logger nick server :channels channels :output output :logging-stream logging-stream :password password @@ -667,11 +635,7 @@ (defun add-channel-logger (logger channel-name) (cond ((find-channel-with-name logger channel-name) - (format (get-private-log-stream logger) - "~A Channel ~A already in logger ~A.~%" - (format-date-time (get-universal-time)) - channel-name logger) - (force-output (get-private-log-stream logger)) + (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)))) @@ -695,11 +659,8 @@ :test #'string-equal)) t) (t - (format - (get-private-log-stream logger) - "~A Channel name ~A not found in logger ~A.~%" - (format-date-time (get-universal-time)) - channel-name logger) + (add-private-log-entry + logger "Channel name ~A not found in logger ~A." channel-name logger) nil)))) (defun add-hook-logger (logger class hook) @@ -716,11 +677,7 @@ (when (and (stringp target) (string-equal target (nickname logger))) (setf (warning-message-utime logger) (received-time msg))) - (format (get-private-log-stream logger) - "~A Killed by ~A~%" - (format-date-time (received-time msg)) - (source msg)) - (force-output (get-private-log-stream logger)))) + (add-private-log-entry logger "Killed by ~A" (source msg)))) (defun error-hook (msg) (let ((text (trailing-argument msg)) @@ -747,21 +704,34 @@ ;; 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 at ~A." - (format-date-time (get-universal-time))))) + (log-daemon-message logger "Disconnected. Attempting reconnection."))) (defun log-reconnection (logger) - (log-daemon-message - logger - "Connection restablished at ~A." (format-date-time (get-universal-time)))) + (log-daemon-message logger "Connection restablished.")) + +#+ignore +(defun is-connected (logger) + (%is-connected logger)) + +(defparameter *timeout* 60) (defun is-connected (logger) + #-allegro (%is-connected logger) + #+allegro (mp:with-timeout (*timeout* nil) + (%is-connected logger))) + +(defun quit-maybe-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)) - (sleep 1)))) + (return-from %is-connected t)) + (daemon-sleep 1)))) (let (*recon-nick* *recon-server* *recon-username* *recon-realname* @@ -778,7 +748,7 @@ (log-disconnection logger) (when (connection logger) - (ignore-errors (quit (connection logger) "Client terminated by server")) + (ignore-errors (quit-maybe-timeout (connection logger) "Client terminated by server")) (setf *recon-nick* (nickname logger) *recon-server* (server logger) *recon-username* (username logger)