Skip to content

Commit

Permalink
improve logging
Browse files Browse the repository at this point in the history 
<release-note>
Add lots of new debug categories suitable for net.aserve::debug-on and
net.aserve::debug-off. See documentation for more.
</release-note>

Also, add log1* (unexported for now), a generic function of (logger
category level message) args through which all logging eventually goes
through. The value of logger is from the logger slot of the current
wserver if the log comes from a server. For the client, it's the
whatever is in *logger*.

This is patch 13.

<documentation>
Note there are no :xmit-proxy-server-request-* categories, because at
the time of reading the request it's not yet known whether it's the
going to be proxied so these show up as :xmit-server-request-*.

Complicate the simple tree of debug categories into a DAG:
:xmit-server-request-command is a subcategory of each of :xmit :server
:request and :command. To turn on server side logging without the
bodies you'd do:

  (net.aserve::debug-on :server)
  (net.aserve::debug-off :body)

The list of debug categories:

:all                                     off
    The mother of all debug features.
:notrap                                  off
    If set than errors in handlers cause a break loop to be entered.
    (parent categories: :all)
:zoom-on-error                           off
    If set then print a zoom to the vhost-error-stream when an error occurs in a handler.
    (parent categories: :all)
:log                                     off
    Category of features that write some kind of log.
    (parent categories: :all)
:xmit                                    off
    Category of features that log the traffic between clients, servers.
    (parent categories: :log)
:info                                    off
    General information.
    (parent categories: :log)
:client                                  off
    Category of features that log client communication.
    (parent categories: :all)
:server                                  off
    Category of features that log server communication.
    (parent categories: :all)
:proxy                                   off
    Category of features that log proxy communication.
    (parent categories: :all)
:request                                 off
    Category of features that log requests.
    (parent categories: :all)
:response                                off
    Category of features that log responses.
    (parent categories: :all)
:command                                 off
    Category of features that log http request commands.
    (parent categories: :all)
:headers                                 off
    Category of features that log request/response headers.
    (parent categories: :all)
:body                                    off
    Category of features that log request/response bodies.
    (parent categories: :all)
:xmit-client-request-command             off
    If set then print the client request commands.
    (parent categories: :xmit, :client, :request, :command)
:xmit-client-request-headers             off
    If set then print the client request headers.
    (parent categories: :xmit, :client, :request, :headers)
:xmit-client-request-body                off
    If set then print the client request bodies.
    (parent categories: :xmit, :client, :request, :body)
:xmit-client-response-headers            off
    If set then print the client response headers.
    (parent categories: :xmit, :client, :response, :headers)
:xmit-client-response-body               off
    If set then print the client response bodies.
    (parent categories: :xmit, :client, :response, :body)
:xmit-server-request-command             off
    If set then print the server request commands.
    (parent categories: :xmit, :server, :request, :command)
:xmit-server-request-headers             off
    If set then print the server request headers.
    (parent categories: :xmit, :server, :request, :headers)
:xmit-server-request-body                off
    If set then print the server request bodies.
    (parent categories: :xmit, :server, :request, :body)
:xmit-server-response-headers            off
    If set then print the server response headers.
    (parent categories: :xmit, :server, :response, :headers)
:xmit-server-response-body               off
    If set then print the server response bodies.
    (parent categories: :xmit, :server, :response, :body)
:xmit-proxy-client-request-command       off
    If set then print the proxy request command sent to the real server.
    (parent categories: :xmit, :proxy, :client, :request, :command)
:xmit-proxy-client-request-headers       off
    If set then print the proxy request headers sent to the real server.
    (parent categories: :xmit, :proxy, :client, :request, :headers)
:xmit-proxy-client-request-body          off
    If set then print the proxy request bodies sent to the real server.
    (parent categories: :xmit, :proxy, :client, :request, :body)
:xmit-proxy-client-response-headers      off
    If set then print the proxy response headers sent by the real server.
    (parent categories: :xmit, :proxy, :client, :response, :headers)
:xmit-proxy-client-response-body         off
    If set then print the proxy response bodies sent by the real server.
    (parent categories: :xmit, :proxy, :client, :response, :body)
:xmit-proxy-server-response-headers      off
    If set then print the proxy response headers sent to the client.
    (parent categories: :xmit, :proxy, :server, :response, :headers)
:xmit-proxy-server-response-body         off
    If set then print the proxy response bodies sent by the client.
    (parent categories: :xmit, :proxy, :server, :response, :body)
</documentation>

Change-Id: I3209c64bfc3f25bc12cafe9cf4be7f7d0029091b
  • Loading branch information
@dklayer
Gabor Melis authored and dklayer committed Mar 14, 2012
1 parent 65d85a2 commit ab9efeb
Show file tree
Hide file tree
Showing 10 changed files with 907 additions and 679 deletions.
434 changes: 224 additions & 210 deletions client.cl
View file

Large diffs are not rendered by default.

5 changes: 4 additions & 1 deletion headers.cl
View file
Expand Up @@ -703,7 +703,10 @@
(let* ((buff (get-sresource *header-block-sresource*)) (let* ((buff (get-sresource *header-block-sresource*))
(end (read-headers-into-buffer sock buff))) (end (read-headers-into-buffer sock buff)))
(if* end (if* end
then (prog1 (parse-and-listify-header-block buff end) then (debug-format :xmit-client-response-headers "~a"
(octets-to-string buff :end end
:external-format :octets))
(prog1 (parse-and-listify-header-block buff end)
(free-sresource *header-block-sresource* buff)) (free-sresource *header-block-sresource* buff))
else (free-sresource *header-block-sresource* buff) else (free-sresource *header-block-sresource* buff)
(error "Incomplete headers sent by server")))) (error "Incomplete headers sent by server"))))
Expand Down
139 changes: 79 additions & 60 deletions log.cl
View file
Expand Up @@ -35,6 +35,29 @@


(in-package :net.aserve) (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 *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 (defvar *save-commands* nil) ; if true then a stream to which to write commands
Expand All @@ -43,21 +66,27 @@
(log-for-wserver *wserver* message format)) (log-for-wserver *wserver* message format))


(defmethod log-for-wserver ((wserver wserver) message format) (defmethod log-for-wserver ((wserver wserver) message format)
;; send log message to the default vhost's error stream ;; send log message to the default vhost's error stream
(logmess-stream message (vhost-error-stream (wserver-default-vhost wserver)) format)) (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 (message stream &optional (format :long)) (defmethod logmess-stream (category level message stream
&optional (format *debug-format*))
;; send the log message to the given stream which should be a ;; send the log message to the given stream which should be a
;; stream object and not a stream indicator (like t) ;; stream object and not a stream indicator (like t)
;; If the stream has a lock use that. ;; If the stream has a lock use that.
(declare (ignore level))
(multiple-value-bind (csec cmin chour cday cmonth cyear) (multiple-value-bind (csec cmin chour cday cmonth cyear)
(decode-universal-time (get-universal-time)) (decode-universal-time (get-universal-time) *log-time-zone*)
(let* ((*print-pretty* nil) (let* ((*print-pretty* nil)
(str (ecase format (str (ecase format
(:long (:long
(format (format
nil "~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%" nil "[~a] ~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%"
(mp:process-name sys:*current-process*) category (mp:process-name sys:*current-process*)
cmonth cday (mod cyear 100) chour cmin csec cmonth cday (mod cyear 100) chour cmin csec
message)) message))
(:brief (:brief
Expand All @@ -72,51 +101,11 @@
else (write-sequence str stream) else (write-sequence str stream)
(finish-output stream))))) (finish-output stream)))))



(defmethod log-request ((req http-request)) (defmethod log-request ((req http-request))
;; after the request has been processed, write out log line ;; after the request has been processed, write out log line
(if* *enable-logging* (if* *enable-logging*
then (let* ((ipaddr (socket:remote-host (request-socket req))) then ;; By default this ends up calling log-request*.
(time (request-reply-date req)) (log1 :access :info 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))))

(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~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))
(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)))))

(if* *save-commands* (if* *save-commands*
then (multiple-value-bind (ok whole uri-string) then (multiple-value-bind (ok whole uri-string)
(match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req)) (match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req))
Expand All @@ -133,15 +122,49 @@
(let ((bod (request-request-body req))) (let ((bod (request-request-body req)))
(and (not (equal "" bod)) bod)) (and (not (equal "" bod)) bod))
(multiple-value-list (get-basic-authorization req)) (multiple-value-list (get-basic-authorization req))
(header-slot-value req :content-type) (header-slot-value req :content-type)))
)) (force-output *save-commands*)))
(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) (defun log-proxy (uri level action extra)
;; log information from the proxy module ;; log information from the proxy module
Expand All @@ -158,7 +181,3 @@
else (net.uri:render-uri uri nil)) else (net.uri:render-uri uri nil))
extra) extra)
:brief)) :brief))




0 comments on commit ab9efeb

Please sign in to comment.