- net-nittin-irc-cvs@common-lisp.net - mailman3.common-lisp.net

[net-nittin-irc-cvs] CVS update: net-nittin-irc/command.lisp net-nittin-irc/protocol.lisp
by Kevin Rosenberg 16 Dec '03

16 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv1338 Modified Files: command.lisp protocol.lisp Log Message: conditionalize sb-bsd-socket usage and warn for implementations where function not implemented Date: Tue Dec 16 13:30:32 2003 Author: krosenberg Index: net-nittin-irc/command.lisp diff -u net-nittin-irc/command.lisp:1.8 net-nittin-irc/command.lisp:1.9 --- net-nittin-irc/command.lisp:1.8 Sun Nov 23 18:21:57 2003 +++ net-nittin-irc/command.lisp Tue Dec 16 13:30:32 2003 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.8 2003/11/23 23:21:57 eenge Exp $ +;;;; $Id: command.lisp,v 1.9 2003/12/16 18:30:32 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -304,6 +304,7 @@ (send-irc-message connection :privmsg (make-ctcp-message message) target)) (defmethod ctcp-chat-initiate ((connection connection) (nickname string)) + #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) (port 44347)) (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) ; arbitrary port @@ -315,4 +316,6 @@ (make-dcc-connection :user (find-user connection nickname) :input-stream t :output-stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) - :socket socket))) + :socket socket)) + #-sbcl (warn "ctcp-chat-initiate is not supported on this implementation.") + ) Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.23 net-nittin-irc/protocol.lisp:1.24 --- net-nittin-irc/protocol.lisp:1.23 Tue Nov 25 08:14:34 2003 +++ net-nittin-irc/protocol.lisp Tue Dec 16 13:30:32 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.23 2003/11/25 13:14:34 eenge Exp $ +;;;; $Id: protocol.lisp,v 1.24 2003/12/16 18:30:32 krosenberg Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -211,13 +211,16 @@ (remote-address nil) (remote-port nil) (output-stream t)) + #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp))) (sb-bsd-sockets:socket-connect socket remote-address remote-port) (make-instance 'dcc-connection :user user :stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) :socket socket - :output-stream t))) + :output-stream t)) + #-sbcl + (warn "make-dcc-connection not supported for this implementation.")) (defmethod read-message ((connection dcc-connection)) (let ((message (read-line (stream connection)))) @@ -237,7 +240,8 @@ (close (stream connection)) (setf (user connection) nil) (setf *dcc-connections* (remove connection *dcc-connections*)) - (sb-bsd-sockets:socket-close (socket connection))) + #+sbcl (sb-bsd-sockets:socket-close (socket connection)) + ) (defmethod connectedp ((connection dcc-connection)) (let ((stream (stream connection)))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 15 Dec '03

15 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv28571 Modified Files: cliki.lisp Log Message: Make cliki read its small definitions file on startup Date: Mon Dec 15 18:11:13 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.6 net-nittin-irc/example/cliki.lisp:1.7 --- net-nittin-irc/example/cliki.lisp:1.6 Mon Dec 15 14:48:19 2003 +++ net-nittin-irc/example/cliki.lisp Mon Dec 15 18:11:12 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.6 2003/12/15 19:48:19 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.7 2003/12/15 23:11:12 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -176,6 +176,7 @@ (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) (defun start-cliki-bot (nick server &rest channels) + (read-small-definitions) (setf *cliki-nickname* nick) (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels)

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/cliki.lisp
by Brian Mastenbrook 15 Dec '03

15 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv21141 Modified Files: cliki.lisp Log Message: Add NickServ authentication Date: Mon Dec 15 14:48:19 2003 Author: bmastenbrook Index: net-nittin-irc/example/cliki.lisp diff -u net-nittin-irc/example/cliki.lisp:1.5 net-nittin-irc/example/cliki.lisp:1.6 --- net-nittin-irc/example/cliki.lisp:1.5 Sat Dec 13 18:44:33 2003 +++ net-nittin-irc/example/cliki.lisp Mon Dec 15 14:48:19 2003 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.5 2003/12/13 23:44:33 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.6 2003/12/15 19:48:19 bmastenbrook Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -131,9 +131,9 @@ (symbol-macrolet ((it ,test)) ,else)))) -(defparameter *cliki-attention-prefix* "cliki: ") +(defparameter *cliki-attention-prefix* "minion: ") -(defparameter *cliki-bot-help* "The CLiki bot supplies small definitions and performs lookups on CLiki. To use it, try ``cliki: term?''. To add a term for IRC, try saying ``cliki: add \"term\" as: definition''; otherwise, edit the corresponding CLiki page.") +(defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition''; otherwise, edit the corresponding CLiki page.") (defun cliki-lookup (term-with-question) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) @@ -144,11 +144,18 @@ (defn (regex-replace "^add \"[^\"]+\" as: (.+)$" first-pass "\\1"))) (add-small-definition term defn) "OK, done.") - (concatenate 'string first-pass ": " - (or - (if (string-equal first-pass "help") *cliki-bot-help*) - (cdr (assoc first-pass *small-definitions* :test #'string-equal)) - (cliki-first-sentence first-pass)))))) + (if (scan "^alias \"([^\"]+)\" as: (.+)$" first-pass) + (let ((term (regex-replace "^alias \"([^\"]+)\" .*$" first-pass "\\1")) + (defn (regex-replace "^alias \"[^\"]+\" as: (.+)$" first-pass "\\1"))) + (add-small-definition term (list defn)) + "OK, done.") + (or + (if (string-equal first-pass "help") *cliki-bot-help*) + (if (scan "^(?i)do my bidding!*$" first-pass) "Yes, my master.") + (concatenate 'string first-pass ": " + (or (let ((term (cdr (assoc first-pass *small-definitions* :test #'string-equal)))) + (if term (if (stringp term) term (cliki-lookup (car term))))) + (cliki-first-sentence first-pass)))))))) (defun valid-cliki-message (message) (eql (search *cliki-attention-prefix* (trailing-argument message) :test #'char-equal) 0)) @@ -161,14 +168,22 @@ (if (valid-cliki-message message) (privmsg *cliki-connection* (first (arguments message)) (cliki-lookup (subseq (trailing-argument message) (length *cliki-attention-prefix*))))))) +(defvar *cliki-nickserv-password* "") + +(defun notice-hook (message) + (if (and (string-equal (source message) "NickServ") + (scan "owned by someone else" (trailing-argument message))) + (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) + (defun start-cliki-bot (nick server &rest channels) (setf *cliki-nickname* nick) (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) - (add-hook *cliki-connection* 'irc::irc-privmsg-message #'msg-hook) + (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) + (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) #+sbcl (add-asynchronous-message-handler *cliki-connection*) #-sbcl (read-message-loop *cliki-connection*)) (defun shuffle-hooks () (irc::remove-hooks *cliki-connection* 'irc::irc-privmsg-message) - (add-hook *cliki-connection* 'irc::irc-privmsg-message #'msg-hook)) + (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook))

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 15 Dec '03

15 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv3001 Modified Files: logger.lisp Log Message: refactor accessors Date: Mon Dec 15 13:16:40 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.9 net-nittin-irc/example/logger.lisp:1.10 --- net-nittin-irc/example/logger.lisp:1.9 Sun Dec 14 14:30:46 2003 +++ net-nittin-irc/example/logger.lisp Mon Dec 15 13:16:40 2003 @@ -1,10 +1,12 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.9 2003/12/14 19:30:46 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.10 2003/12/15 18:16:40 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license +;;;; TODO: mode, topic + (in-package cl-user) (defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) @@ -75,26 +77,27 @@ (declare (ignore second minute hour day-of-week daylight-p zone)) (make-output-name name year month day-of-month))) -(defun html-title (channel) +(defun html-title (channel-name) (multiple-value-bind - (second minute hour day-of-month month year day-of-week daylight-p zone) + (second minute hour day-of-month month year dow daylight-p zone) (decode-universal-time (get-universal-time)) - (declare (ignore second minute hour day-of-week daylight-p zone)) + (declare (ignore second minute hour dow daylight-p zone)) (format nil "~A IRC Log ~4,'0D/~2,'0D/~2,'0D" - (string-left-trim '(#\#) (name channel)) year month day-of-month))) + (string-left-trim '(#\#) channel-name) year month day-of-month))) -(defun output-file-header (logger channel istream) - (case (elt (formats logger) istream) +(defun write-file-header (format channel-name stream) + (case format (:html - (format (elt (streams channel) istream) + (format stream "<?xml version='1.0' ?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") - (format (elt (streams channel) istream) "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body id='body'>~%" - (html-title channel))))) + (format stream + "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body id='body'>~%<table><tbody>~%" + (html-title channel-name))))) -(defun output-file-footer (logger channel istream) - (case (elt (formats logger) istream) +(defun write-file-footer (format stream) + (case format (:html - (format (elt (streams channel) istream) "</body></html>~%")))) + (format stream "</tbody></table></body></html>~%")))) (defun log-file-path (output-root channel-name year month day format) (make-pathname @@ -110,30 +113,48 @@ (t "txt")))) -(defun log-file-path-utime (utime output-root channel-name format) +(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-name output-root channel-name year month day format))) + (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 ensure-output-stream-for-user-directory (utime logger channel istream) +(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-directory-output (utime logger channel istream) (let ((name (make-output-name-utime (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) + (unless (string= name (get-output-name channel istream)) + (when (get-stream channel istream) + (write-file-footer (get-format logger istream) + (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) - (elt (formats logger) istream) utime))) + (get-format logger istream) utime))) (unless (probe-file path) (ensure-directories-exist path) - (setf (elt (streams channel) istream) + (setf (get-stream 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) + (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)))))) @@ -141,16 +162,17 @@ "Ensures that *output-stream* is correct." (cond ((streamp (user-output logger)) - (unless (elt (streams channel) istream) - (setf (elt (streams channel) istream) (user-output logger)))) + (unless (get-stream channel istream) + (setf (get-stream channel istream) (user-output logger)))) ((pathnamep (user-output logger)) (cond + ;; user specified a named file for output ((pathname-name (user-output logger)) - ;; a file is named for output - (setf (elt (streams channel) istream) + (setf (get-stream channel istream) (open (user-output logger) :direction :output :if-exists :append))) + ;; user specified a directory for output files (t - (ensure-output-stream-for-user-directory utime logger channel istream)))))) + (ensure-output-stream-for-directory-output utime logger channel istream)))))) (defun format-utime (utime) (multiple-value-bind @@ -166,7 +188,6 @@ (declare (ignore second day-of-month month year day-of-week daylight-p zone)) (format nil "~2,'0D:~2,'0D" hour minute))) - (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))) @@ -185,7 +206,8 @@ (write-string item stream))))))) (defun user-address (msg) - (let ((split (split *user-address-scanner* (raw-message-string msg) :with-registers-p t))) + (let ((split (split *user-address-scanner* (raw-message-string msg) + :with-registers-p t))) (if (second split) (second split) ""))) @@ -193,19 +215,19 @@ (defun %output-event (stream format utime type source text object user-address) (case format (:html - (write-string "<div>" stream) + (write-string "<tr><td class='time'>" stream) (write-string (format-utime utime) stream) - (write-string " " stream) + (write-string "</td> " stream) (case type (:privmsg - (format stream "<~A> ~A" + (format stream "<td><~A></td><td class='msg'>~A</td>" source (activate-uris text))) (:action (format stream - "*~A* ~A" + "<td>*~A* ~A</td>" source (activate-uris text))) (t - (format stream "~A [~A] ~A" + (format stream "<td>~A [~A] ~A" source user-address text) (when object (case type @@ -213,8 +235,11 @@ (format stream " [~A]" object)) (t - (format stream " ~A" object)))))) - (format stream "</div>~%")) + (format stream " ~A" object)))) + (write-string "</td>" stream) + )) + (write-string "</tr>" stream) + (write-char #\Newline stream)) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" utime type source text object user-address)) (t @@ -238,10 +263,10 @@ (defun output-event-for-a-stream (msg type text object logger channel istream) (ensure-output-stream (received-time msg) logger channel istream) - (%output-event stream (elt (streams channel) istream) (elt (formats logger) istream) - (received-time sg) (source msg) text object + (%output-event (get-stream channel istream) (get-format logger istream) + (received-time msg) type (source msg) text object (when (is-info-type type) (user-address msg))) - (force-output stream)) + (force-output (get-stream channel istream))) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -290,6 +315,18 @@ (output-event msg :kick "has been kicked from" (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 create-logger (nick server &key channels output (logging-stream t) (async t) @@ -311,21 +348,11 @@ :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)) - :output-root - (when (and (pathnamep output) - (null (pathname-name output))) - output) - :current-output-names - (make-list (length formats)))) - :user-output output - :formats formats))) - (mapc #'(lambda (channel) (join conn channel)) channels) + :channels (make-channels channels formats output) + :user-output output + :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) @@ -353,10 +380,11 @@ (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)) + (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

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv2371 Modified Files: irclogs.css logger.lisp Log Message: refactoring for simplicity Date: Sun Dec 14 14:30:46 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.6 net-nittin-irc/example/irclogs.css:1.7 --- net-nittin-irc/example/irclogs.css:1.6 Sun Dec 14 11:10:29 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 14:30:46 2003 @@ -9,7 +9,7 @@ .time { color:#666; } -.subject { color:#22C; font-weight: bold; } +.source { color:#22C; font-weight: bold; } .msg { color:#000; } @@ -23,7 +23,7 @@ .user-address { color:#444; } -.info-subject { color:#22C; font-weight: bold; font-size:80% } +.info-source { color:#22C; font-weight: bold; font-size:80% } .info-brack { color:#AAA; font-size:80%} Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.8 net-nittin-irc/example/logger.lisp:1.9 --- net-nittin-irc/example/logger.lisp:1.8 Sun Dec 14 12:13:19 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 14:30:46 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.8 2003/12/14 17:13:19 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.9 2003/12/14 19:30:46 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -9,7 +9,8 @@ (defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) (:export #:add-logger - #:quit-logger)) + #:quit-logger + #:log-file-path)) (in-package irc-logger) (defclass channel () @@ -17,9 +18,7 @@ :documentation "Name of channel.") (streams :initarg :streams :reader streams :documentation "List of output streams.") - (default-pathname :initarg :default-pathname :reader default-pathname) - (base-name :initarg :base-name :reader base-name - :documentation "Base file name for channel") + (output-root :initarg :output-root :reader output-root) (current-output-names :initarg :current-output-names :accessor current-output-names))) @@ -65,12 +64,16 @@ (defun find-logger-with-nick (nick) (find nick (the list *loggers*) :test #'string-equal :key #'nickname)) -(defun make-output-name (base-name utime) +(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)) - (format nil "~A~4,'0D.~2,'0D.~2,'0D" base-name year month day-of-month))) + (make-output-name name year month day-of-month))) (defun html-title (channel) (multiple-value-bind @@ -93,28 +96,36 @@ (:html (format (elt (streams channel) istream) "</body></html>~%")))) -(defun log-file-directory (utime pathname) - (append (pathname-directory pathname) - (list - (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 day-of-month hour day-of-week daylight-p zone)) - (format nil "~4,'0D-~2,'0D" year month))))) +(defun log-file-path (output-root channel-name year month day format) + (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 (case format + (:html "html") + (:sexp "sexp") + (t "txt")))) + + +(defun log-file-path-utime (utime output-root channel-name format) + (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-name output-root channel-name year month day format))) (defun ensure-output-stream-for-user-directory (utime logger channel istream) - (let ((name (make-output-name (base-name channel) utime))) + (let ((name (make-output-name-utime (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 :directory (log-file-directory utime (default-pathname channel)) - :name name - :type (case (elt (formats logger) istream) - (:html "html") - (:sexp "sexp") - (t "txt"))))) + (let ((path (log-file-path-utime (output-root channel) (name channel) + (elt (formats logger) istream) utime))) (unless (probe-file path) (ensure-directories-exist path) (setf (elt (streams channel) istream) @@ -141,7 +152,14 @@ (t (ensure-output-stream-for-user-directory utime logger channel istream)))))) -(defun format-time (utime) +(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) @@ -172,56 +190,58 @@ (second split) ""))) +(defun %output-event (stream format utime type source text object user-address) + (case format + (:html + (write-string "<div>" stream) + (write-string (format-utime utime) stream) + (write-string " " stream) + (case type + (:privmsg + (format stream "<~A> ~A" + source (activate-uris text))) + (:action + (format stream + "*~A* ~A" + source (activate-uris text))) + (t + (format stream "~A [~A] ~A" + source user-address text) + (when object + (case type + (:quit + (format stream " [~A]" + object)) + (t + (format stream " ~A" object)))))) + (format stream "</div>~%")) + (:sexp + (format stream "(~W ~W ~W ~W ~W ~W)~%" utime type source text object user-address)) + (t + (format stream "~A " (format-utime utime)) + (case type + (:privmsg + (format stream "<~A> ~A" source text)) + (:action + (format stream "*~A* ~A" source text)) + (t + (format stream "[info] ~A [~A] ~A" source user-address text) + (when object + (format stream (case type + (:quit " [~A]") + (t " ~A")) + object)))) + (write-char #\Newline stream)))) + +(defun is-info-type (type) + (not (or (eq :action type) (eq :privmsg type)))) + (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 - (write-string "<div>" stream) - (write-string (format-time (received-time msg)) stream) - (write-string " " stream) - (case type - (:privmsg - (format stream "<~A> ~A" - source (activate-uris text))) - (:action - (format stream - "*~A* ~A" - source (activate-uris text))) - (t - (format stream "~A [~A] ~A" - source (user-address msg) text) - (when object - (case type - (:quit - (format stream " [~A]" - object)) - (t - (format stream " ~A" object)))))) - (format stream "</div>~%")) - (:sexp - (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) - type source text object - (unless (or (eq :privmsg type) (eq :action type)) - (user-address msg)))) - (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] ~A" source (user-address msg) text) - (when object - (format stream (case type - (:quit " [~A]") - (t " ~A")) - object)))) - (write-char #\Newline stream))) - (force-output stream))) + (%output-event stream (elt (streams channel) istream) (elt (formats logger) istream) + (received-time sg) (source msg) text object + (when (is-info-type type) (user-address msg))) + (force-output stream)) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -296,22 +316,10 @@ collect (make-instance 'channel :name (nth i channels) :streams (make-list (length formats)) - :default-pathname + :output-root (when (and (pathnamep output) (null (pathname-name output))) - (merge-pathnames - (make-pathname :directory - (list :relative - (string-left-trim - '(#\#) - (nth i channels)))) - output)) - :base-name - (concatenate 'string - (string-left-trim - '(#\#) - (nth i channels)) - "-") + output) :current-output-names (make-list (length formats)))) :user-output output

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv14934 Modified Files: logger.lisp Log Message: store in year-month directories Date: Sun Dec 14 12:13:19 2003 Author: krosenberg Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.7 net-nittin-irc/example/logger.lisp:1.8 --- net-nittin-irc/example/logger.lisp:1.7 Sun Dec 14 11:10:29 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 12:13:19 2003 @@ -1,15 +1,16 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.7 2003/12/14 16:10:29 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.8 2003/12/14 17:13:19 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license (in-package cl-user) -(defpackage logger +(defpackage irc-logger (:use :common-lisp :irc :cl-ppcre) - (:export #:start-logger-bot)) -(in-package logger) + (:export #:add-logger + #:quit-logger)) +(in-package irc-logger) (defclass channel () ((name :initarg :name :reader name @@ -92,6 +93,15 @@ (:html (format (elt (streams channel) istream) "</body></html>~%")))) +(defun log-file-directory (utime pathname) + (append (pathname-directory pathname) + (list + (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 day-of-month hour day-of-week daylight-p zone)) + (format nil "~4,'0D-~2,'0D" year month))))) + (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)) @@ -99,7 +109,8 @@ (output-file-footer logger channel istream) (close (elt (streams channel) istream))) (setf (elt (current-output-names channel) istream) name) - (let ((path (make-pathname :defaults (default-pathname channel) :name name + (let ((path (make-pathname :directory (log-file-directory utime (default-pathname channel)) + :name name :type (case (elt (formats logger) istream) (:html "html") (:sexp "sexp")

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irc-logger.asd net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv24784 Modified Files: irclogs.css logger.lisp Added Files: irc-logger.asd Log Message: add asdf system Date: Sun Dec 14 11:10:29 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.5 net-nittin-irc/example/irclogs.css:1.6 --- net-nittin-irc/example/irclogs.css:1.5 Sun Dec 14 09:29:24 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 11:10:29 2003 @@ -4,7 +4,7 @@ #body { font-family: fixed; background: #FFFFFF; color: #000000; - margin: 0px 0px 10px 0px; + /* margin: 10px 10px 10px 1px;*/ } .time { color:#666; } Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.6 net-nittin-irc/example/logger.lisp:1.7 --- net-nittin-irc/example/logger.lisp:1.6 Sun Dec 14 08:50:04 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 11:10:29 2003 @@ -1,19 +1,9 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.6 2003/12/14 13:50:04 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.7 2003/12/14 16:10:29 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg ;;;; License: net-nittin-irc license - -;;; Quickstart: -;;; - 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)) (in-package cl-user) (defpackage logger

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv21507 Modified Files: irclogs.css Log Message: better font-family Date: Sun Dec 14 09:29:24 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.4 net-nittin-irc/example/irclogs.css:1.5 --- net-nittin-irc/example/irclogs.css:1.4 Sun Dec 14 08:50:04 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 09:29:24 2003 @@ -1,7 +1,7 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ -#body { font-family: courier, fixed; +#body { font-family: fixed; background: #FFFFFF; color: #000000; margin: 0px 0px 10px 0px;

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv2906 Modified Files: irclogs.css logger.lisp Log Message: css fixes Date: Sun Dec 14 08:50:05 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.3 net-nittin-irc/example/irclogs.css:1.4 --- net-nittin-irc/example/irclogs.css:1.3 Sun Dec 14 08:01:50 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 08:50:04 2003 @@ -1,22 +1,21 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ -#body { font-family: fixed; - font-size: 10px; +#body { font-family: courier, fixed; background: #FFFFFF; color: #000000; margin: 0px 0px 10px 0px; } -.time { color:#888; } - -.privmsg { } +.time { color:#666; } .subject { color:#22C; font-weight: bold; } -.msg ( color:#000; ) +.msg { color:#000; } + +.brack { color:#777; } -.action-brack { color:#500; } +.action-brack { color:#511; } .action-name { color:#A22; font-weight:bold; } @@ -26,7 +25,7 @@ .info-subject { color:#22C; font-weight: bold; font-size:80% } -.info-brack { color:#CCC; font-size:80%} +.info-brack { color:#AAA; font-size:80%} .info-msg { color:#000; font-size:80%} Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.5 net-nittin-irc/example/logger.lisp:1.6 --- net-nittin-irc/example/logger.lisp:1.5 Sun Dec 14 08:01:50 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 08:50:04 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.5 2003/12/14 13:01:50 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.6 2003/12/14 13:50:04 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -94,7 +94,7 @@ (:html (format (elt (streams channel) istream) "<?xml version='1.0' ?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") - (format (elt (streams channel) istream) "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body>~%" + (format (elt (streams channel) istream) "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body id='body'>~%" (html-title channel))))) (defun output-file-footer (logger channel istream) @@ -193,7 +193,12 @@ (format stream "~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (case type + (:quit + (format stream " [~A]" + object)) + (t + (format stream " ~A" object)))))) (format stream "</div>~%")) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) @@ -210,9 +215,12 @@ (t (format stream "[info] ~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (format stream (case type + (:quit " [~A]") + (t " ~A")) + object)))) (write-char #\Newline stream))) - (force-output stream)))/ + (force-output stream))) (defun output-event (msg type text &optional object) (dolist (logger *loggers*) @@ -251,8 +259,7 @@ (first (arguments msg)))) (defun quit-hook (msg) - (output-event msg :quit "has quit" - (concatenate 'string "[" (trailing-argument msg) "]"))) + (output-event msg :quit "has quit" (trailing-argument msg))) (defun join-hook (msg) (output-event msg :join "has joined"

1 0

[net-nittin-irc-cvs] CVS update: net-nittin-irc/example/irclogs.css net-nittin-irc/example/logger.lisp
by Kevin Rosenberg 14 Dec '03

14 Dec '03

Update of /project/net-nittin-irc/cvsroot/net-nittin-irc/example In directory common-lisp.net:/tmp/cvs-serv11495 Modified Files: irclogs.css logger.lisp Log Message: use css style names rather than hard coding the colors, weights, and sizes Date: Sun Dec 14 08:01:51 2003 Author: krosenberg Index: net-nittin-irc/example/irclogs.css diff -u net-nittin-irc/example/irclogs.css:1.2 net-nittin-irc/example/irclogs.css:1.3 --- net-nittin-irc/example/irclogs.css:1.2 Sun Dec 14 06:53:41 2003 +++ net-nittin-irc/example/irclogs.css Sun Dec 14 08:01:50 2003 @@ -1,16 +1,17 @@ /* -*- Mode: CSS -*- */ /* Cascading stylesheet for logger.lisp */ +#body { font-family: fixed; + font-size: 10px; + background: #FFFFFF; + color: #000000; + margin: 0px 0px 10px 0px; + } + .time { color:#888; } .privmsg { } -.action { } - -.info { font-size:85%; font-style:italic; } - -.brack ( color:#CCC; ) - .subject { color:#22C; font-weight: bold; } .msg ( color:#000; ) @@ -23,8 +24,10 @@ .user-address { color:#444; } -.info-brack { color:#CCC; } +.info-subject { color:#22C; font-weight: bold; font-size:80% } + +.info-brack { color:#CCC; font-size:80%} -.info-msg { color:#000; } +.info-msg { color:#000; font-size:80%} -.object { color:#822; } +.info-object { color:#822; font-size:80%; } Index: net-nittin-irc/example/logger.lisp diff -u net-nittin-irc/example/logger.lisp:1.4 net-nittin-irc/example/logger.lisp:1.5 --- net-nittin-irc/example/logger.lisp:1.4 Sun Dec 14 06:53:41 2003 +++ net-nittin-irc/example/logger.lisp Sun Dec 14 08:01:50 2003 @@ -1,5 +1,5 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id: logger.lisp,v 1.4 2003/12/14 11:53:41 krosenberg Exp $ +;;;; $Id: logger.lisp,v 1.5 2003/12/14 13:01:50 krosenberg Exp $ ;;;; ;;;; Purpose: A logging bot ;;;; Author: Kevin Rosenberg @@ -14,9 +14,6 @@ (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 @@ -84,12 +81,21 @@ (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))) +(defun html-title (channel) + (multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time (get-universal-time)) + (declare (ignore second minute hour day-of-week daylight-p zone)) + (format nil "~A IRC Log ~4,'0D/~2,'0D/~2,'0D" + (string-left-trim '(#\#) (name channel)) 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>~%")))) + "<?xml version='1.0' ?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%") + (format (elt (streams channel) istream) "<html xmlns='http://www.w3.org/1999/xhtml'>~%<head>~%<title>~A</title>~%<link rel='stylesheet' href='/irclogs.css' type='text/css' />~%</head>~%<body>~%" + (html-title channel))))) (defun output-file-footer (logger channel istream) (case (elt (formats logger) istream) @@ -172,14 +178,9 @@ (assert (streamp stream)) (case (elt (formats logger) istream) (:html - (format stream - "<div class='~A'>" - (case type - (:privmsg "privmsg") - (:action "action") - (t "info"))) + (write-string "<div>" stream) (write-string (format-time (received-time msg)) stream) - (format stream " ") + (write-string " " stream) (case type (:privmsg (format stream "<~A> ~A" @@ -189,10 +190,10 @@ "*~A* ~A" source (activate-uris text))) (t - (format stream "~A [~A] ~A" + (format stream "~A [~A] ~A" source (user-address msg) text) (when object - (format stream " ~A" object)))) + (format stream " ~A" object)))) (format stream "</div>~%")) (:sexp (format stream "(~W ~W ~W ~W ~W ~W)~%" (received-time msg) @@ -215,16 +216,22 @@ (defun output-event (msg type text &optional object) (dolist (logger *loggers*) - (let* ((channel-name (case type - (:join - (trailing-argument msg)) - (t - (car (last (arguments msg)))))) - (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 text object logger channel i)))))) + (case type + (:quit + (dolist (channel (channels logger)) + (dotimes (i (length (formats logger))) + (output-event-for-a-stream msg type text object logger channel i)))) + (t + (let* ((channel-name (case type + (:join + (trailing-argument msg)) + (t + (car (last (arguments msg)))))) + (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 text object logger channel i)))))))) (defun privmsg-hook (msg) (output-event msg :privmsg (trailing-argument msg)))

1 0