[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
Kevin Rosenberg
krosenberg at common-lisp.net
Sun Dec 14 10:40:09 UTC 2003
Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example
In directory common-lisp.net:/tmp/cvs-serv3113
Modified Files:
logger.lisp
Added Files:
irclogs.css
Log Message:
add multiple,simultaneous loggers, channels, and formats. add html and sexp formats.
Date: Sun Dec 14 05:40:09 2003
Author: krosenberg
Index: net-nittin-irc/example/logger.lisp
diff -u net-nittin-irc/example/logger.lisp:1.2 net-nittin-irc/example/logger.lisp:1.3
--- net-nittin-irc/example/logger.lisp:1.2 Sat Dec 13 23:22:24 2003
+++ net-nittin-irc/example/logger.lisp Sun Dec 14 05:40:08 2003
@@ -1,54 +1,132 @@
;;;; -*- Mode: Lisp -*-
-;;;; $Id: logger.lisp,v 1.2 2003/12/14 04:22:24 krosenberg Exp $
+;;;; $Id: logger.lisp,v 1.3 2003/12/14 10:40:08 krosenberg Exp $
;;;;
;;;; Purpose: A logging bot
;;;; Author: Kevin Rosenberg
;;;; License: net-nittin-irc license
;;; Quickstart:
-;;; - load net-nittin-irc asdf system
+;;; - have net-nittin-irc, cl-ppcre paths on your asdf:*central-registry*
;;; - load this file: logger.lisp
;;; - (logger:start-logger-bot <nickname> <server> &keys channels output)
+(unless (find-package 'net-nittin-irc)
+ (asdf:operate 'asdf:load-op 'net-nittin-irc))
+(unless (find-package 'cl-ppcre)
+ (asdf:operate 'asdf:load-op 'cl-ppcre))
+#+ignore
+(unless (find-package 'puri)
+ (asdf:operate 'asdf:load-op 'puri))
+
(in-package cl-user)
(defpackage logger
- (:use :common-lisp :irc)
+ (:use :common-lisp :irc :cl-ppcre)
(:export #:start-logger-bot))
(in-package logger)
-(defvar *bot-nickname* nil)
-(defvar *connection* nil)
-(defvar *output* nil "User output parametet to start-logger-bot.")
-(defvar *current-output-name* "Name of current output file.")
-(defvar *base-name* nil "Base name for output files.")
-(defvar *output-stream* nil "Current output stream.")
+(defclass channel ()
+ ((name :initarg :name :reader name
+ :documentation "Name of channel.")
+ (streams :initarg :streams :reader streams
+ :documentation "List of output streams.")
+ (base-name :initarg :base-name :reader base-name
+ :documentation "Base file name for channel")
+ (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.")
+ (base-name :initarg :base-name :reader base-name
+ :documentation "Base name of log files.")
+ (formats :initarg :formats :reader formats
+ :documentation
+ "A list of output formats.")))
+
+(defvar *loggers* nil "List of active loggers.")
+(defparameter *uri-scanner*
+ (create-scanner
+ '(:register
+ (:alternation
+ (:sequence :word-boundary "http://"
+ (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9))
+ (:greedy-repetition 1 nil :non-whitespace-char-class))
+ (:sequence :word-boundary "ftp://"
+ (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9))
+ (:greedy-repetition 1 nil :non-whitespace-char-class))
+ (:sequence :word-boundary "mailto:"
+ (:char-class (:range #\a #\z) (:range #\a #\z) (:range #\0 #\9))
+ (: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 (utime)
+(defun make-output-name (base-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))
- (format nil "~A~4,'0D-~2,'0D-~2,'0D" *base-name* year month day-of-month)))
+ (format nil "~A~4,'0D-~2,'0D-~2,'0D" base-name year month day-of-month)))
+
+(defun output-file-header (logger channel istream)
+ (case (elt (formats logger) istream)
+ (:html
+ (format (elt (streams channel) istream)
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%")
+ (format (elt (streams channel) istream) "<html><head><link rel="stylesheet" href="irclogs.css" type="text/css" /></head><body>~%"))))
+
+(defun output-file-footer (logger channel istream)
+ (case (elt (formats logger) istream)
+ (:html
+ (format (elt (streams channel) istream) "</body></html>~%"))))
+
+(defun ensure-output-stream-for-user-directory (utime logger channel istream)
+ (let ((name (make-output-name (base-name channel) utime)))
+ (unless (string= name (elt (current-output-names channel) istream))
+ (when (elt (streams channel) istream)
+ (output-file-footer logger channel istream)
+ (close (elt (streams channel) istream)))
+ (setf (elt (current-output-names channel) istream) name)
+ (let ((path (make-pathname :defaults (user-output logger) :name name
+ :type (case (elt (formats logger) istream)
+ (:html "html")
+ (:sexp "sexp")
+ (t "txt")))))
+ (unless (probe-file path)
+ (setf (elt (streams channel) istream)
+ (open path :direction :output :if-exists :error
+ :if-does-not-exist :create))
+ (output-file-header logger channel istream)
+ (close (elt (streams channel) istream)))
+ (setf (elt (streams channel) istream)
+ (open path :direction :output :if-exists :append
+ :if-does-not-exist :error))))))
-(defun ensure-output-stream (utime)
+(defun ensure-output-stream (utime logger channel istream)
"Ensures that *output-stream* is correct."
(cond
- ((streamp *output*)
- (unless *output-stream*
- (setq *output-stream* *output*)))
- ((pathnamep *output*)
- (let ((name (make-output-name utime)))
- (unless (string= name *current-output-name*)
- (when *output-stream*
- (close *output-stream*))
- (setq *current-output-name* name)
- (setq *output-stream*
- (open (make-pathname :defaults *output* :name name
- :type "txt")
- :direction :output
- :if-exists :append
- :if-does-not-exist :create)))))))
-
+ ((streamp (user-output logger))
+ (unless (elt (streams channel) istream)
+ (setf (elt (streams channel) istream) (user-output logger))))
+ ((pathnamep (user-output logger))
+ (cond
+ ((pathname-name (user-output logger))
+ ;; a file is named for output
+ (setf (elt (streams channel) istream)
+ (open (user-output logger) :direction :output :if-exists :append)))
+ (t
+ (ensure-output-stream-for-user-directory utime logger channel istream))))))
+
(defun format-time (utime)
(multiple-value-bind
(second minute hour day-of-month month year day-of-week daylight-p zone)
@@ -56,94 +134,198 @@
(declare (ignore second day-of-month month year day-of-week daylight-p zone))
(format nil "~2,'0D:~2,'0D" hour minute)))
-(defun output-event (msg text)
- (ensure-output-stream (received-time msg))
- (assert (streamp *output-stream*))
- (format *output-stream* "~A ~A~%"
- (format-time (received-time msg))
- text)
- (force-output *output-stream*))
-
-(defmethod irc::irc-message-event ((msg irc::irc-privmsg-message))
- (output-event msg
- (format nil "<~A> ~A"
- (source msg)
- (trailing-argument msg))))
-
-
-(defmethod irc::irc-message-event ((msg irc::irc-nick-message))
- (output-event msg
- (format nil "[info] ~A is now known as ~A"
- (source msg)
- (trailing-argument msg))))
-
-(defmethod irc::irc-message-event ((msg irc::irc-part-message))
- (output-event msg
- (format nil "[info] ~A has left ~A"
- (source msg)
- (first (arguments msg)))))
-
-(defmethod irc::irc-message-event ((msg irc::irc-quit-message))
- (output-event msg
- (format nil "[info] ~A has quit ~A"
- (source msg)
- (trailing-argument msg))))
-
-(defmethod irc::irc-message-event ((msg irc::irc-join-message))
- (output-event msg
- (format nil "[info] ~A has joined ~A"
- (source msg)
- (trailing-argument msg))))
-
-(defmethod irc::irc-message-event ((msg irc::irc-kick-message))
- (output-event msg
- (format nil "[info] ~A has been kicked from ~A"
- (source msg)
- (first (arguments msg)))))
-
-(defmethod irc::irc-message-event ((msg irc::ctcp-action-message))
- (output-event msg
- (format nil "*~A* ~A"
- (source msg)
- (subseq (trailing-argument msg)
- 8
- (- (length (trailing-argument msg)) 1)))))
-
-
-(defun start-logger-bot (nick server &key channels output
- (base-name "log-")
- (logging-stream t)
- (async t))
+
+(defun activate-uris (str)
+ "Find any URI's in a string and make them HTML clickable."
+ (let ((split (split *uri-scanner* str :with-registers-p t)))
+ (if (= 1 (length split))
+ str
+ (with-output-to-string (stream)
+ (dolist (item split)
+ (if (and (> (length item) 6)
+ (or
+ (string-equal "http://" (subseq item 0 7))
+ (string-equal "ftp://" (subseq item 0 6))
+ (string-equal "mailto:" (subseq item 0 7)))
+ ;; (ignore-errors (puri:parse-uri item))
+ t)
+ (format stream "<a href='~A'>~A</a>" item item)
+ (write-string item stream)))))))
+
+(defun output-event-for-a-stream (msg type text object logger channel istream)
+ (ensure-output-stream (received-time msg) logger channel istream)
+ (let ((source (source msg))
+ (stream (elt (streams channel) istream)))
+ (assert (streamp stream))
+ (case (elt (formats logger) istream)
+ (:html
+ (format stream
+ "<div class='~A'><span class='time'>"
+ (case type
+ (:privmsg "privmsg")
+ (:action "action")
+ (t "info")))
+ (write-string (format-time (received-time msg)) stream)
+ (format stream "</span> ")
+ (case type
+ (:privmsg
+ (format stream "<span class='brack'><</span><span class='subject'>~A</span><span class='brack'>></span> <span class='msg'>~A</span>"
+ source (activate-uris text)))
+ (:action
+ (format stream
+ "<span class='action-brack'>*</span><span class='action-name'>~A</span><span class='action-brack'>*</span> <span class='action-msg'>~A</span>"
+ source (activate-uris text)))
+ (t
+ (format stream "<span class='subject'>~A</span> <span class='info-msg'>~A</span>"
+ source text)
+ (when object
+ (format stream " <span class='object'>~A</span>" object))))
+ (format stream "</div>~%"))
+ (:sexp
+ (format stream "(~W ~W ~W ~W ~W)~%" (received-time msg)
+ type source text object))
+ (t
+ (format stream "~A " (format-time (received-time msg)))
+ (case type
+ (:privmsg
+ (format stream "<~A> ~A" source text))
+ (:action
+ (format stream "*~A* ~A" source text))
+ (t
+ (format stream "[info] ~A ~A" source text)
+ (when object
+ (format stream " ~A" object))))
+ (write-char #\Newline stream)))
+ (force-output stream)))/
+
+(defun output-event (msg type text &optional object)
+ (dolist (logger *loggers*)
+ (let* ((channel-name (car (last (arguments msg))))
+ (channel (find channel-name (the list (channels logger))
+ :test #'string-equal :key #'name)))
+ (print channel-name)
+ (print channel)
+ (when channel
+ (dotimes (i (length (formats logger)))
+ (output-event-for-a-stream msg type text object logger channel i))))))
+
+(defun privmsg-hook (msg)
+ (output-event msg :privmsg (trailing-argument msg)))
+
+(defun action-hook (msg)
+ (output-event msg :action
+ (subseq (trailing-argument msg)
+ 8
+ (- (length (trailing-argument msg)) 1))))
+
+(defun nick-hook (msg)
+ (output-event msg :nick "is now known as"
+ (trailing-argument msg)))
+
+(defun part-hook (msg)
+ (output-event msg :part "has left"
+ (first (arguments msg))))
+
+(defun quit-hook (msg)
+ (output-event msg :quit "has quit"
+ (concatenate 'string "[" (trailing-argument msg) "]")))
+
+(defun join-hook (msg)
+ (output-event msg :join "has joined"
+ (trailing-argument msg)))
+
+(defun kick-hook (msg)
+ (output-event msg :kick "has been kicked from"
+ (first (arguments msg))))
+
+(defun create-logger (nick server &key channels output
+ (base-name "log-")
+ (logging-stream t)
+ (async t)
+ (formats '(:text)))
"OUTPUT may be a pathname or a stream"
;; check arguments
(assert channels)
+ (assert formats)
(assert (stringp base-name))
- (if (stringp channels)
+ (if (atom channels)
(setq channels (list channels)))
+ (if (atom formats)
+ (setq formats (list formats)))
(if (stringp output)
(setq output (parse-namestring output)))
- (setq *bot-nickname* nick)
- (setq *base-name* base-name)
- (setq *output* output)
- (when *connection*
- (warn "Closing open logger connection.")
- (quit *connection*)
- (sleep 2)) ;; give the server a chance to close out connection
-
- (setq *connection*
- (connect :nickname *bot-nickname* :server server
- :logging-stream logging-stream))
- (mapc #'(lambda (channel) (join *connection* channel)) channels)
-
- (reset-hooks)
- (cond
- (async
- #+sbcl (add-asynchronous-message-handler *connection*)
- #-sbcl (read-message-loop *connection*))
- (t
- (read-message-loop *connection*))))
-
-
-(defun reset-hooks ()
- (irc::remove-all-hooks *connection*))
+ (let* ((conn (connect :nickname nick :server server
+ :logging-stream logging-stream))
+ (logger (make-instance
+ 'logger
+ :connection conn
+ :nick nick
+ :server server
+ :channels
+ (loop for i from 0 to (1- (length channels))
+ collect (make-instance 'channel
+ :name (nth i channels)
+ :streams (make-list (length formats))
+ :base-name
+ (concatenate 'string
+ base-name
+ (string-left-trim
+ '(#\#)
+ (nth i channels))
+ "-")
+ :current-output-names
+ (make-list (length formats))))
+ :user-output output
+ :base-name base-name
+ :formats formats)))
+ (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)
+ (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 (elt (streams channel) i))
+ (close (elt (streams channel) i))
+ (setf (elt (streams channel) i) nil))))
+ (setq *loggers* (delete nick *loggers* :test #'string-equal :key #'nickname))
+ t))))
+
+(defun add-logger (nick server &key channels output
+ (base-name "log-")
+ (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
+ :base-name base-name :logging-stream logging-stream
+ :async async :formats formats)))
+ (push logger *loggers*)
+ logger))
+
More information about the Net-nittin-irc-cvs
mailing list