;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: SYSLOG -*- ;;; $Revision: 1.1 $ ;;; Copyright © 2002 Paul Foley (mycroft@actrix.gen.nz) ;;; All rights reserved. Use and verbatim redistribution permitted. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE ;;; 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) HOWEVER CAUSED AND ON ANY THEORY OF ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. #+CMU (ext:file-comment "$Header: /mnt/Lisp/RCS/syslog.lisp,v 1.1 2005/06/02 04:24:24 paul Exp paul $") (defpackage "SYSLOG" (:use "COMMON-LISP") (:export "ADD-SYSLOG-HANDLER" "REMOVE-SYSLOG-HANDLER" "SYSLOG" "STREAM-HANDLER" "SYSLOG-HANDLER")) (in-package "SYSLOG") #|| SYSLOG ident level message args... ident -- a keyword level -- a keyword (from +levels+) message -- a format control string args -- format arguments * Logs the message to any interested handlers. ADD-SYSLOG-HANDLER idents levels handler args... idents -- T, keyword, or list of keywords levels -- T, keyword (from +levels+), or list of: key, (:exactly key), (:except key) or (:not key) handler -- symbol naming a function (or the function itself) args -- args to be passed on as the first argument to the handler function * Puts handler function on *HANDLERS*, returns identifier for REMOVE-SYSLOG-HANDLER The handler listens for SYSLOG events with a matching IDENT and LEVEL. If IDENTS is T, it matches any ident. If it's a keyword, it matches that keyword, or any keyword that has the same initial print name string, followed by a dot -- e.g., the value :foo matches :foo, :foo.bar, etc.; The level matches if levels is T or the call to SYSLOG has the same or higher level (but see :exactly, :except and :not) REMOVE-SYSLOG-HANDLER handler handler -- identifier returned by ADD-SYSLOG-HANDLER * Removes handler from *HANDLERS* Handlers are functions of four arguments: [By convention, the function should return T if it logs anything, and NIL if it doesn't for some reason, but the return value is never examined] There are two predefined handlers: STREAM-HANDLER logs to one or more streams E.g., (add-syslog-handler #'stream-handler ...) causes interesting SYSLOG events to be logged to the named streams. If no streams are provided, messages go to *TRACE-OUTPUT* may also be a pathname or a pathname namestring, in which case output will be appended to the named file SYSLOG-HANDLER logs via syslogd(8) E.g., (add-syslog-handler #'syslog-handler ...) causes interesting SYSLOG events to be logged to syslogd. , if supplied, are a set of keyword/value pairs as follows: :device -- the socket address to contact syslogd either "/path/to/unix/socket" or an internet host address where syslogd is expected to be listening on the default port (UDP port 514) (defaults to "/dev/log") :facility -- the syslogd facility value (as a keyword) which is to be used. (defaults to :user) :level -- the syslogd level value (as a keyword) which is to by used. (defaults to :notice) :tag -- the ident value to be logged. (defaults to the value passed to SYSLOG, converted to a lower-case string) ||# ;; Use the same levels and names as syslogd, for now. (defconstant +levels+ '((:emerg . 0) (:alert . 1) (:crit . 2) (:err . 3) (:warning . 4) (:notice . 5) (:info . 6) (:debug . 7))) (defvar *ident* nil) (defvar *handlers* '()) (defstruct handler idents levels function args) (defun %ident= (a b) (or (eq a b) (and (> (length (symbol-name a)) (length (symbol-name b))) (string= a b :end1 (length (symbol-name b))) (char= #\. (schar (symbol-name a) (length (symbol-name b))))))) (defun %match (handler ident level) (flet ((match-ident (x ident) (cond ((eq x t) t) ((keywordp x) (%ident= ident x)) ;; Note: this ought to be able to do exclusions, similar ;; to MATCH-LEVEL below, but it'll do for now... ((consp x) (some (lambda (x) (%ident= ident x)) x)))) (match-level (x level) (cond ((eq x t) t) ((integerp x) (>= x level)) ((consp x) (let ((match nil)) (dolist (item x match) (cond ((integerp item) (if (>= item level) (setf match t))) ((eq (car item) :exactly) (if (= (cdr item) level) (setf match t))) ((eq (car item) :not) (if (>= (cdr item) level) (setf match nil))) ((eq (car item) :except) (if (= (cdr item) level) (setf match nil)))))))))) (and (match-ident (handler-idents handler) ident) (match-level (handler-levels handler) level)))) (defun add-syslog-handler (idents levels handler &rest args) "Add a syslog handler for the given idents and levels. IDENTS may be the symbol T, a keyword, or a list of keywords. LEVELS may be the symbol T, a level keyword as used by SYSLOG, or a list which may contain level keywords or sublists of the form (CONTROL LEVEL) where CONTROL is one of :EXACTLY, :EXCEPT or :NOT and LEVEL is level keyword. (:exactly :info) enables this handler if the level given to SYSLOG is exactly :info (i.e., not a higher level such as :crit). (:except :info) disables this handler if the level given to SYSLOG is exactly :info. (:not :info) disables this handler if the level given to SYSLOG is :info or greater. The return value may be passed to REMOVE-SYSLOG-HANDLER to remove this handler." (let ((handler (make-handler :idents idents :levels (cond ((eq levels t) t) ((atom levels) (cdr (assoc levels +levels+))) (t (mapcar (lambda (x) (if (consp x) (cons (first x) (cdr (assoc (second x) +levels+))) (cdr (assoc x +levels+)))) levels))) :function handler :args args))) (push handler *handlers*) handler)) (defun remove-syslog-handler (handler) "Remove a syslog handler, given the value returned by ADD-SYSLOG-HANDLER." (setf *handlers* (delete handler *handlers*)) t) (defun syslog (ident level message &rest args) "Log MESSAGE (a format control string which may use ARGS) to the logger named by IDENT at the given LEVEL. Handling of this message can be configured using ADD-SYSLOG-HANDLER." (let ((ident (or ident *ident*)) (level (cdr (assoc level +levels+))) (message (apply #'format nil message args))) (when (and ident level) (dolist (handler *handlers*) (when (%match handler ident level) (funcall (handler-function handler) (handler-args handler) ident (car (rassoc level +levels+)) message)))))) (defun %syslog-format (priority message ident &key machine pid) ;; Format used by syslogd(8) (flet ((getpid () #+CMU (unix:unix-getpid) #+Allegro (excl::getpid) #| add other implementations here |#)) (multiple-value-bind (sec min hr day mon) (get-decoded-time) (format nil "~&~@[<~D>~]~A ~2,' D ~2,'0D:~2,'0D:~2,'0D~ ~:[~*~; ~A~]~@[ ~A~]~:[~*~;[~D]~]: ~A" priority (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (1- mon)) day hr min sec machine (machine-instance) ident pid (getpid) message)))) (defun stream-handler (args ident level message) "Append to the stream(s) or file(s) given in ARGS. If ARGS is NIL, write to *TRACE-OUTPUT instead." (declare (ignore level)) (labels ((log-to-stream (stream message) (cond ((or (pathnamep stream) (stringp stream)) (with-open-file (stream stream :direction :output :if-exists :append :if-does-not-exist :create) (princ message stream) (terpri stream))) ((streamp stream) (fresh-line stream) (princ message stream) (terpri stream))))) (let ((stream (or (first args) *trace-output*)) (message (%syslog-format nil message (string-downcase ident)))) (log-to-stream stream message) (dolist (stream (rest args)) (log-to-stream stream message)) t))) (defconstant +syslogd-levels+ '((:emerg . 0) (:alert . 1) (:crit . 2) (:err . 3) (:warning . 4) (:notice . 5) (:info . 6) (:debug . 7) ;; deprecated names (:panic . 0) (:error . 3) (:warn . 4))) (defconstant +syslogd-facilities+ '((:kern . 0) (:user . 1) (:mail . 2) (:daemon . 3) (:auth . 4) (:syslog . 5) (:lpr . 6) (:news . 7) (:uucp . 8) (:cron . 9) (:authpriv . 10) (:ftp . 11) ;; other values through 15 reserved (:local0 . 16) (:local1 . 17) (:local2 . 18) (:local3 . 19) (:local4 . 20) (:local5 . 21) (:local6 . 22) (:local7 . 23))) (defun syslog-handler (args ident level message) "Log via syslogd(8). ARGS is (&key (device \"/dev/log\") (facility :user) (level :notice) (tag ident)). If the DEVICE name starts with a \"/\", it's taken to be the pathname of a Unix-domain socket used to communicate with a local syslogd; otherwise it's taken to be a hostname where syslogd is expected to be listening on the standard port." (declare (ignore level)) (let ((device (or (getf args :device) "/dev/log")) (facility (cdr (assoc (or (getf args :facility) :user) +syslogd-facilities+))) (level (cdr (assoc (or (getf args :level) :notice) +syslogd-levels+))) (tag (or (getf args :tag) (string-downcase ident)))) (when (and facility level) #+CMU (let ((sock (if (char= (schar device 0) #\/) (ext:connect-to-unix-socket device :datagram) (ext:connect-to-inet-socket device 514 :datagram))) (text (%syslog-format (logior (ash facility 3) level) message tag #| :machine t |# :pid t))) (unix:unix-write sock text 0 (length text)) (ext:close-socket sock) t) #+Allegro (let ((sock (if (char= (schar device 0) #\/) (socket:make-socket :address-family :file :connect :active :remote-filename device :type :datagram) (socket:make-socket :address-family :internet :connect :active :remote-host device :remote-port 514 :type :datagram))) (text (%syslog-format (logior (ash facility 3) level) message tag #| :machine t |# :pid t))) (socket:send-to sock text (length text)) (close sock) t) #| add other implementations here |# )))