X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=logger.lisp;h=3bb165f1560f7145d07c48cada914db38b582331;hb=d289ec60467cae9601d4eb2f1b150037bf586fb9;hp=c434cd3577a810f56db5b968616fe7f27963cf58;hpb=411d337e9bf17aef3f4a67c37bb9b1fb6aa08c85;p=irc-logger.git diff --git a/logger.lisp b/logger.lisp index c434cd3..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))) @@ -246,11 +234,6 @@ (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string msg))))) -(uffi:def-foreign-type time-t :unsigned-long) -(uffi:def-function ("ctime" c-ctime) - ((time (* time-t))) - :returning :cstring) - (defconstant +posix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) @@ -273,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)) @@ -326,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) @@ -346,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) @@ -372,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)))))) @@ -414,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))) @@ -442,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)))))) @@ -493,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) @@ -563,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 @@ -653,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 @@ -672,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)))) @@ -700,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) @@ -721,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)) @@ -752,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* @@ -783,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)