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 $
4 ;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
30 (in-package :hunchentoot
)
33 ((pathname :initarg
:pathname
34 :accessor log-file-pathname
35 :documentation
"Current pathname of this LOG-FILE
38 :accessor log-file-stream
39 :documentation
"Open stream to current log file.")
40 (lock :initform
(make-lock "Hunchentoot 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.")))
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
))
53 :if-does-not-exist
:create
57 :external-format
+utf-8
+))))
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
)))))
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."
87 (defvar ,special-variable
(make-instance 'log-file
:pathname
,pathname
)
88 ,(format nil
"The ~A" documentation
))
90 (defun ,visible-name
()
91 ,(format nil
"Returns the ~A" documentation
)
92 (log-file-pathname ,special-variable
))
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
)))))
102 (define-log-file log-file
*log-file
* *log-pathname
*
103 "file to use to log general messages.")
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
)
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
)))
120 (define-log-file access-log-file
*access-log-file
* *access-log-pathname
*
121 "File to use to log access messages.")
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
127 (with-log-file (stream *access-log-file
*)
128 (format stream
"~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] \"~A ~A~@[?~A~] ~
129 ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
131 (header-in* :x-forwarded-for
)