log.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/log.lisp,v 1.10 2008/02/13 16:02:17 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2008, Dr. Edmund Weitz.  All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (defclass log-file ()
  33   ((pathname :initarg :pathname
  34              :accessor log-file-pathname
  35              :documentation "Current pathname of this LOG-FILE
  36 instance.")
  37    (stream :initform nil
  38            :accessor log-file-stream
  39            :documentation "Open stream to current log file.")
  40    (lock :initform (make-lock "Hunchentoot log file lock")
  41          :reader log-file-lock
  42          :documentation "Lock to guard write access to the log file.
  43 Every write to the log file is done with the lock held to prevent
  44 unwanted mixing of log entries.")))
  45
  46 (defun ensure-log-stream-open (log-file)
  47   "Ensures that the stream to the given LOG-FILE instance is open."
  48   (unless (log-file-stream log-file)
  49     (setf (log-file-stream log-file)
  50           (make-flexi-stream (open (ensure-directories-exist (log-file-pathname log-file))
  51                                    :direction :output
  52                                    :element-type 'octet
  53                                    :if-does-not-exist :create
  54                                    :if-exists :append
  55                                    #+:openmcl #+:openmcl
  56                                    :sharing :lock)
  57                              :external-format +utf-8+))))
  58
  59 (defmacro with-log-file ((stream-var log-file) &body body)
  60   "Execute BODY with STREAM-VAR bound to the stream of the LOG-FILE,
  61 which is assumed to be an instance of the LOG-FILE class.  The stream
  62 will be opened if neccessary, and the lock of the LOG-FILE will be
  63 held during execution of BODY."
  64   (with-unique-names (retval)
  65     `(with-lock-held ((log-file-lock ,log-file))
  66        (ensure-log-stream-open ,log-file)
  67        ;; In order to reduce logging overhead, we print the message
  68        ;; to to an in-memory buffer and then send it to the
  69        ;; FLEXI-STREAM in one operation in the hope to reduce
  70        ;; external format conversion overhead.
  71        (let* ((,stream-var (make-string-output-stream))
  72               (,retval (multiple-value-list (progn ,@body))))
  73          (princ (get-output-stream-string ,stream-var)
  74                 (log-file-stream ,log-file))
  75          (force-output (log-file-stream ,log-file))
  76          (values-list ,retval)))))
  77
  78 (defmacro define-log-file (visible-name special-variable pathname documentation)
  79   "Define a log file with VISIBLE-NAME being the name of the getter
  80 and setter function to change the path of the log file,
  81 SPECIAL-VARIABLE being the special variable bound to the LOG-FILE
  82 instance that represents the log file internally, PATHNAME be the
  83 default pathname to the log file and DOCUMENTATION be the docstring to
  84 be used for all three of them."
  85   `(progn
  86
  87      (defvar ,special-variable (make-instance 'log-file :pathname ,pathname)
  88        ,(format nil "The ~A" documentation))
  89
  90      (defun ,visible-name ()
  91        ,(format nil "Returns the ~A" documentation)
  92        (log-file-pathname ,special-variable))
  93
  94      (defun (setf ,visible-name) (pathname)
  95        ,(format nil "Sets the ~A" documentation)
  96        (with-lock-held ((log-file-lock ,special-variable))
  97          (when (log-file-stream ,special-variable)
  98            (close (log-file-stream ,special-variable))
  99            (setf (log-file-stream ,special-variable) nil))
 100          (setf (log-file-pathname ,special-variable) pathname)))))
 101
 102 (define-log-file log-file *log-file* *log-pathname*
 103   "file to use to log general messages.")
 104
 105 (defmethod log-message (log-level format &rest args)
 106   "Sends a formatted message to the file denoted by *LOG-FILE*.
 107 FORMAT and ARGS are as in FORMAT.  LOG-LEVEL is a keyword denoting the
 108 log level or NIL in which case it is ignored."
 109   (with-log-file (stream *log-file*)
 110     (format stream "[~A~@[ [~A]~]] " (iso-time) log-level)
 111     (apply #'format stream format args)
 112     (terpri stream)))
 113
 114 (defun log-message* (log-level format &rest args)
 115   "Internal function accepting the same arguments as LOG-MESSAGE and
 116 using the message logger of *SERVER* \(if there is one)."
 117   (when-let (message-logger (server-message-logger *server*))
 118     (apply message-logger log-level format args)))
 119
 120 (define-log-file access-log-file *access-log-file* *access-log-pathname*
 121   "File to use to log access messages.")
 122
 123 (defun log-access (&key return-code content content-length)
 124   "Sends a standardized access log message to the file denoted by
 125 *ACCESS-LOG-FILE* with information about the current request and
 126 response."
 127   (with-log-file (stream *access-log-file*)
 128     (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] \"~A ~A~@[?~A~] ~
 129                     ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
 130             (remote-addr*)
 131             (header-in* :x-forwarded-for)
 132             (authorization)
 133             (request-method*)
 134             (script-name*)
 135             (query-string*)
 136             (server-protocol*)
 137             return-code
 138             content
 139             content-length
 140             (referer)
 141             (user-agent))))
 142