forked from franzinc/aserve
/
log.cl
169 lines (153 loc) · 6.31 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
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; log.cl
;;
;; See the file LICENSE for the full license governing this code.
;;
;;
;; 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)
(eval-when (:compile-toplevel) (declaim (optimize (speed 3))))
(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
;; Avoid bug24536 (*current-process* may be nil during finalization).
(when sys:*current-process* (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~]"
;; Avoid bug24536 (*current-process* may be nil during finalization).
(when mp:*current-process*
(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))