-
Notifications
You must be signed in to change notification settings - Fork 30
/
log.cl
183 lines (168 loc) · 7.05 KB
/
log.cl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; log.cl
;;
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
;; $Id: log.cl,v 1.27 2008/02/04 19:03:59 jkf Exp $
;; Description:
;; iserve's logging
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(in-package :net.aserve)
(defun log1 (category level message &key (logger *logger*))
(log1* logger category level message))
(defgeneric log1* (logger category level message)
(:documentation "This the new, extensible logger interface to which
all others defer. By default, category :access is handled by
log-request* while the rest goes to logmess-stream. Note message is
not necessarily a string: for instance it is a request object
for :access which allows for more flexibility in presentation.")
(:method (logger category level message)
(declare (ignore logger))
(logmess-stream category level message *debug-stream*))
(:method (logger (category (eql :xmit-server-response-headers)) level message)
(declare (ignore logger))
;; time is :pre or :post depending on whether the headers are
;; generated before or after the body
(destructuring-bind (time string) message
(logmess-stream category level (format nil "~a ~s" time string)
*debug-stream*)))
(:method (logger (category (eql :access)) level (request http-request))
(declare (ignore logger level))
(log-request* request)))
(defvar *enable-logging* t) ; to turn on/off the standard logging method
(defvar *save-commands* nil) ; if true then a stream to which to write commands
(defun logmess (message &optional (format :long))
(log-for-wserver *wserver* message format))
(defmethod log-for-wserver ((wserver wserver) message format)
;; send log message to the default vhost's error stream
(let ((*debug-stream* (vhost-error-stream (wserver-default-vhost wserver)))
(*debug-format* format))
(log1 :aserve :info message)))
(defvar *log-time-zone* 0)
(defmethod logmess-stream (category level message stream
&optional (format *debug-format*))
;; send the log message to the given stream which should be a
;; stream object and not a stream indicator (like t)
;; If the stream has a lock use that.
(declare (ignore level))
(multiple-value-bind (csec cmin chour cday cmonth cyear)
(decode-universal-time (get-universal-time) *log-time-zone*)
(let* ((*print-pretty* nil)
(str (ecase format
(:long
(format
nil "[~a] ~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%"
category (mp:process-name sys:*current-process*)
cmonth cday (mod cyear 100) chour cmin csec
message))
(:brief
(format nil "~2,'0d:~2,'0d:~2,'0d - ~a~%" chour cmin csec
message))))
(lock (getf (excl::stream-property-list stream) :lock)))
(if* lock
then (mp:with-process-lock (lock)
(if* (open-stream-p stream)
then (write-sequence str stream)
(finish-output stream)))
else (write-sequence str stream)
(finish-output stream)))))
(defmethod log-request ((req http-request))
;; after the request has been processed, write out log line
(if* *enable-logging*
then ;; By default this ends up calling log-request*.
(log1 :access :info req))
(if* *save-commands*
then (multiple-value-bind (ok whole uri-string)
(match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req))
(declare (ignore ok whole))
(format *save-commands*
"((:method . ~s) (:uri . ~s) (:proto . ~s) ~% (:code . ~s)~@[~% (:body . ~s)~]~@[~% (:auth . ~s)~]~@[~% (:ctype . ~s)~])~%"
(request-method req)
uri-string
(request-protocol req)
(let ((obj (request-reply-code req)))
(if* obj
then (response-number obj)
else 999))
(let ((bod (request-request-body req)))
(and (not (equal "" bod)) bod))
(multiple-value-list (get-basic-authorization req))
(header-slot-value req :content-type)))
(force-output *save-commands*)))
(defun log-request* (req)
(let* ((entry (format-access-log-entry req))
(stream (vhost-log-stream (request-vhost req)))
(lock (and (streamp stream)
(getf (excl::stream-property-list stream)
:lock))))
(macrolet ((do-log ()
'(progn (format stream "~a~%" entry)
(force-output stream))))
(if* lock
then (mp:with-process-lock (lock)
; in case stream switched out while we weren't busy
; get the stream again
(setq stream (vhost-log-stream (request-vhost req)))
(do-log))
else (do-log)))))
(defun format-access-log-entry (req)
(let* ((ipaddr (socket:remote-host (request-socket req)))
(time (request-reply-date req))
(code (let ((obj (request-reply-code req)))
(if* obj
then (response-number obj)
else 999)))
(length (or (request-reply-content-length req)
#+(and allegro (version>= 6))
(excl::socket-bytes-written
(request-socket req)))))
(format nil "~A~A~a - - [~a] ~s ~s ~s"
(if* *log-wserver-name*
then (wserver-name *wserver*)
else "")
(if* *log-wserver-name*
then " "
else "")
(socket:ipaddr-to-dotted ipaddr)
(maybe-universal-time-to-date time)
(request-raw-request req)
code
(or length -1))))
(defun log-proxy (uri level action extra)
;; log information from the proxy module
;;
(logmess
(format nil "~a ~d ~a ~a~@[ ~s~]"
(or (getf (mp:process-property-list mp:*current-process*)
'short-name)
(mp:process-name mp:*current-process*))
level
action
(if* (stringp uri)
then uri
else (net.uri:render-uri uri nil))
extra)
:brief))