From b05ae9c734ac836f89d48b3b17e6db21bb7ffa26 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 16 Dec 2003 21:48:20 +0000 Subject: [PATCH] r8339: initial import --- LICENSE | 21 +++ debian/changelog | 5 + debian/compat | 1 + debian/control | 17 +++ debian/copyright | 30 ++++ debian/postinst | 47 ++++++ debian/prerm | 38 +++++ debian/rules | 79 ++++++++++ debian/upload.sh | 4 + irc-logger.asd | 15 ++ logger.lisp | 379 +++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 15 ++ 12 files changed, 651 insertions(+) create mode 100644 LICENSE create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100755 debian/upload.sh create mode 100644 irc-logger.asd create mode 100644 logger.lisp create mode 100644 package.lisp diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..913211a --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2003 Kevin Rosenberg + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER EXPRESSED NOR +IMPLIED WARRANTIES - THIS INCLUDES, BUT IS NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.IN +NO WAY ARE THE AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE, +DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..3f008d5 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +cl-irc-logger (0.2-1) unstable; urgency=low + + * Initial upload + + -- Kevin M. Rosenberg Tue, 16 Dec 2003 14:37:39 -0700 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..7a527ec --- /dev/null +++ b/debian/control @@ -0,0 +1,17 @@ +Source: cl-irc-logger +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>> 4.0.0) +Standards-Version: 3.6.1.0 + +Package: cl-irc-logger +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37), cl-irc, cl-ppcre +Description: Internet Relay Channel Logger + cl-irc-logger provides a multi-channel logger for IRC. It is a library + written in Common Lisp and requires knowledge of Common Lisp to + setup and use this library. + + + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..9d202c6 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,30 @@ +Debian Copyright Section +======================== + +Upstream Source URL: http://files.b9.com/irc-logger/ +Upstream Authors: Kevin Rosenberg +Debian Maintainer: Kevin M. Rosenberg + +Upstream Copyright Statement +============================ +Copyright (c) 2003 Kevin Rosenberg + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER EXPRESSED NOR +IMPLIED WARRANTIES - THIS INCLUDES, BUT IS NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.IN +NO WAY ARE THE AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE, +DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) + diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..5c5c9c4 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,47 @@ +#! /bin/sh +set -e + +LISP_PKG=irc-logger + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..fd426dc --- /dev/null +++ b/debian/prerm @@ -0,0 +1,38 @@ +#! /bin/sh +set -e + +# package name according to lisp +LISP_PKG=irc-logger + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..cafe23b --- /dev/null +++ b/debian/rules @@ -0,0 +1,79 @@ +#!/usr/bin/make -f + +pkg := cl-irc-logger +debpkg := cl-irc-logger + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-irc := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-irc-logger.postinst.* debian/cl-irc-logger.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/irc-logger. + dh_installdirs $(clc-systems) $(clc-irc) $(doc-dir) + dh_install irc-logger.asd $(shell echo *.lisp) $(clc-irc) + dh_link $(clc-irc)/irc-logger.asd $(clc-systems)/irc-logger.asd + +# Build architecture-independent files here. +binary-indep: build install + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs + dh_installexamples +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..7d782b6 --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,4 @@ +#!/bin/sh +set -e + +dup irc-logger -Uftp.med-info.com -D/home/ftp/irc-logger -C"/home/kevin/bin/remove-old-versions irc-logger latest" -su $* diff --git a/irc-logger.asd b/irc-logger.asd new file mode 100644 index 0000000..b36a25d --- /dev/null +++ b/irc-logger.asd @@ -0,0 +1,15 @@ +;;;; -*- Mode: Lisp -*- +;;;; ASDF definition for irc-logger +;;;; $Id: irc-logger.asd,v 1.1 2003/12/14 16:10:29 krosenberg Exp $ + +(in-package cl-user) +(defpackage irc-logger-system (:use :cl :asdf)) +(in-package irc-logger-system) + +(defsystem irc-logger + :depends-on (cl-irc cl-ppcre) + :components ((:file "package") + (:file "logger" :depends-on ("package")))) + + + diff --git a/logger.lisp b/logger.lisp new file mode 100644 index 0000000..9123cb8 --- /dev/null +++ b/logger.lisp @@ -0,0 +1,379 @@ +;;;; -*- 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)) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..a5f04f2 --- /dev/null +++ b/package.lisp @@ -0,0 +1,15 @@ +;;;; -*- Mode: Lisp -*- +;;;; $Id: logger.lisp,v 1.11 2003/12/16 21:19:56 krosenberg Exp $ +;;;; + +(in-package cl-user) + +(defpackage irc-logger + (:use :common-lisp :irc :cl-ppcre) + (:export #:add-logger + #:quit-logger + #:log-file-path + #:add-hook-logger + #:remove-hook-logger + #:*loggers*)) + -- 2.34.1