--- /dev/null
+;;;; -*- Mode: Lisp -*-
+;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $
+;;;;
+;;;; Purpose: A IRC logging bot
+;;;; Author: Kevin Rosenberg
+
+(in-package irc-logger)
+
+(defclass channel ()
+ ((name :initarg :name :reader name
+ :documentation "Name of channel.")
+ (streams :initarg :streams :reader streams
+ :documentation "List of output streams.")
+ (output-root :initarg :output-root :reader output-root)
+ (current-output-names :initarg :current-output-names :accessor current-output-names)))
+
+
+(defclass logger ()
+ ((connection :initarg :connection :reader connection
+ :documentation "IRC connection object.")
+ (nick :initarg :nick :reader nickname
+ :documentation "Nickname of the bot.")
+ (server :initarg :server :reader server
+ :documentation "Connected IRC server.")
+ (channels :initarg :channels :reader channels
+ :documentation "List of channels.")
+ (user-output :initarg :user-output :reader user-output
+ :documentation
+ "Output parameter from user, maybe stream or pathname.")
+ (unichannel :initarg :unichannel :reader unichannel :type boolean
+ :documentation "T if user-output is directory for individual channel output.")
+ (formats :initarg :formats :reader formats
+ :documentation
+ "A list of output formats.")))
+
+(defvar *loggers* nil "List of active loggers.")
+
+(defparameter *user-address-scanner*
+ (create-scanner
+ '(:sequence #\!
+ (:register
+ (:greedy-repetition 1 nil :non-whitespace-char-class)))
+ :case-insensitive-mode t))
+
+(defun find-logger-with-nick (nick)
+ (find nick (the list *loggers*) :test #'string-equal :key #'nickname))
+
+(defun make-output-name (name year month day)
+ (format nil "~A-~4,'0D.~2,'0D.~2,'0D"
+ (string-left-trim '(#\#) name) year month day))
+
+(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))
+ (make-output-name name year month day-of-month)))
+
+(defgeneric write-file-header (format channel-name stream))
+
+(defmethod write-file-header ((format t) channel-name stream)
+ (declare (ignore format channel-name stream))
+ )
+
+(defgeneric write-file-footer (format channel-name stream))
+
+(defmethod write-file-footer ((format t) channel-name stream)
+ (declare (ignore format channel-name stream))
+ )
+
+(defun %log-file-path (output-root channel-name year month day type)
+ (make-pathname
+ :defaults output-root
+ :directory (append (pathname-directory output-root)
+ (list
+ (string-left-trim '(#\#) channel-name)
+ (format nil "~4,'0D-~2,'0D" year month)))
+ :name (make-output-name channel-name year month day)
+ :type type))
+
+(defgeneric log-file-path (output-root channel-name year month day format))
+
+(defmethod log-file-path (output-root channel-name year month day (format (eql :raw)))
+ (%log-file-path output-root channel-name year month day "raw"))
+
+(defmethod log-file-path (output-root channel-name year month day (format (eql :sexp)))
+ (%log-file-path output-root channel-name year month day "sexp"))
+
+(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"))
+
+
+(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)))
+
+(defun get-stream (channel istream)
+ (elt (streams channel) istream))
+
+(defun (setf get-stream) (value channel istream)
+ (setf (elt (streams channel) istream) value))
+
+(defun get-format (logger istream)
+ (elt (formats logger) istream))
+
+(defun get-output-name (channel istream)
+ (elt (current-output-names channel) istream))
+
+(defun (setf get-output-name) (value channel istream)
+ (setf (elt (current-output-names channel) istream) value))
+
+(defun ensure-output-stream-for-unichannel (utime logger channel istream)
+ (let ((name (make-output-name-utime (name channel) utime)))
+ (unless (string= name (get-output-name channel istream))
+ (when (get-stream channel istream)
+ (write-file-footer (get-format logger istream)
+ (name channel)
+ (get-stream channel istream))
+ (close (get-stream channel istream)))
+ (setf (get-output-name channel istream) name)
+ (let ((path (log-file-path-utime (output-root channel) (name channel)
+ (get-format logger istream) utime)))
+ (unless (probe-file path)
+ (ensure-directories-exist path)
+ (setf (get-stream channel istream)
+ (open path :direction :output :if-exists :error
+ :if-does-not-exist :create))
+ (write-file-header (get-format logger istream)
+ (name channel)
+ (get-stream channel istream))
+ (close (get-stream channel istream)))
+ (setf (get-stream channel istream)
+ (open path :direction :output :if-exists :append
+ :if-does-not-exist :error))))))
+
+(defun ensure-output-stream (utime logger channel istream)
+ "Ensures that *output-stream* is correct."
+ (cond
+ ((streamp (user-output logger))
+ (unless (get-stream channel istream)
+ (setf (get-stream channel istream) (user-output logger))))
+ ((pathnamep (user-output logger))
+ (cond
+ ((unichannel logger)
+ (ensure-output-stream-for-unichannel utime logger channel istream))
+ (t
+ (setf (get-stream channel istream)
+ (open (user-output logger) :direction :output :if-exists :append)))))))
+
+(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)))
+ (if (second split)
+ (second split)
+ "")))
+
+(defun need-user-address? (type)
+ (not (or (eq :action type) (eq :privmsg type))))
+
+(defgeneric %output-event (format stream utime type channel source text msg unichannel))
+
+(defmethod %output-event ((format t) stream utime type channel source text
+ msg unichannel)
+ (%output-event :raw stream utime type channel source text msg unichannel))
+
+(defmethod %output-event ((format (eql :raw)) stream utime type channel source text
+ msg unichannel)
+ (declare (ignore unichannel))
+ (format stream "~S~%" (string-right-trim '(#\return) (raw-message-string 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)))))
+
+(defmethod %output-event ((format (eql :text)) stream utime type channel source text
+ msg unichannel)
+ (format stream "~A " (format-utime utime))
+ (when (and (null unichannel) channel)
+ (format stream "[~A] " channel))
+
+ (let ((user-address (when (need-user-address? type) (user-address msg))))
+ (case type
+ (:privmsg
+ (format stream "<~A> ~A" source text))
+ (:action
+ (format stream "*~A* ~A" source text))
+ (:join
+ (format stream "~A [~A] has joined ~A" source user-address channel))
+ (:part
+ (format stream "-!- ~A [~A] has left ~A" source user-address channel))
+ (:nick
+ (format stream "-!- ~A is now known as ~A" source text))
+ (: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))
+ (: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))
+ (t
+ (warn "Unhandled msg type ~A." type))))
+ (write-char #\Newline stream))
+
+(defun output-event-for-a-stream (msg type channel text logger istream)
+ (ensure-output-stream (received-time msg) logger channel istream)
+ (%output-event (get-format logger istream) (get-stream channel istream)
+ (received-time msg) type (name channel) (source msg) text msg
+ (unichannel logger))
+ (force-output (get-stream channel istream)))
+
+(defun output-event (msg type channel-name &optional text)
+ (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))))
+ (t
+ (let* ((channel (find channel-name (the list (channels logger))
+ :test #'string-equal :key #'name)))
+ (when channel
+ (dotimes (i (length (formats logger)))
+ (output-event-for-a-stream msg type channel text logger i))))))))
+
+(defun privmsg-hook (msg)
+ (output-event msg :privmsg (first (arguments msg)) (trailing-argument msg)))
+
+(defun action-hook (msg)
+ (output-event msg :action (first (arguments msg))
+ (subseq (trailing-argument msg) 8
+ (- (length (trailing-argument msg)) 1))))
+
+(defun nick-hook (msg)
+ (output-event msg :nick nil (trailing-argument msg)))
+
+(defun part-hook (msg)
+ (output-event msg :part (first (arguments msg))))
+
+(defun quit-hook (msg)
+ (output-event msg :quit (trailing-argument msg)))
+
+(defun join-hook (msg)
+ (output-event msg :join (trailing-argument msg)))
+
+(defun kick-hook (msg)
+ (output-event msg :kick (first (arguments msg))))
+
+(defun notice-hook (msg)
+ (output-event msg :notice (first (arguments msg)) (trailing-argument msg)))
+
+(defun topic-hook (msg)
+ (output-event msg :topic (first (arguments msg)) (trailing-argument msg)))
+
+(defun mode-hook (msg)
+ (output-event msg :mode (first (arguments msg))))
+
+(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))))
+
+(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
+ (logging-stream t)
+ (async t)
+ (formats '(:text)))
+ "OUTPUT may be a pathname or a stream"
+ ;; check arguments
+ (assert channels)
+ (assert formats)
+ (if (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
+ :logging-stream logging-stream))
+ (logger (make-instance
+ 'logger
+ :connection conn
+ :nick nick
+ :server server
+ :channels (make-channels channels formats output)
+ :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)
+ (cond
+ (async
+ #+sbcl (add-asynchronous-message-handler conn)
+ #-sbcl (read-message-loop conn))
+ (t
+ (read-message-loop conn)))
+ logger))
+
+(defun quit-logger (nick)
+ "Quit the active connection with nick and remove from active list."
+ (let ((logger (find-logger-with-nick nick)))
+ (cond
+ ((null logger)
+ (warn "No active connection found with nick ~A." nick)
+ nil)
+ (t
+ (irc:quit (connection 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))))
+ (setq *loggers*
+ (delete nick *loggers* :test #'string-equal :key #'nickname))
+ t))))
+
+(defun add-logger (nick server &key channels output
+ (logging-stream t)
+ (async t)
+ (formats '(:text)))
+ (when (find-logger-with-nick nick)
+ (warn "Closing previously active connection.")
+ (quit-logger nick))
+ (let ((logger
+ (create-logger nick server :channels channels :output output
+ :logging-stream logging-stream
+ :async async :formats formats)))
+ (push logger *loggers*)
+ logger))
+
+(defun add-hook-logger (logger msg hook)
+ (add-hook (connection logger) msg hook))
+
+(defun remove-hook-logger (logger msg)
+ (remove-hook (connection logger) msg))
projects / irc-logger.git / commitdiff