From ab9efeb4918b8cc3971b48863eabc69885b7dbc5 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Thu, 2 Feb 2012 17:00:23 +0100 Subject: [PATCH] improve logging Add lots of new debug categories suitable for net.aserve::debug-on and net.aserve::debug-off. See documentation for more. 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. 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) Change-Id: I3209c64bfc3f25bc12cafe9cf4be7f7d0029091b --- client.cl | 434 +++++++++++++++++++------------------- headers.cl | 5 +- log.cl | 139 +++++++------ main.cl | 413 ++++++++++++++++++++++++++----------- packages.cl | 3 +- parse.cl | 34 ++- proxy.cl | 95 ++++----- publish.cl | 435 +++++++++++++++++++-------------------- test/t-aserve.cl | 26 ++- webactions/websession.cl | 2 +- 10 files changed, 907 insertions(+), 679 deletions(-) diff --git a/client.cl b/client.cl index 6a732afa..e99b1300 100644 --- a/client.cl +++ b/client.cl @@ -363,26 +363,27 @@ (unwind-protect (let (new-location) - - (loop - (if* (catch 'premature-eof - (read-client-response-headers creq - :throw-on-eof - (and connection - 'premature-eof)) - ;; if it's a continue, then start the read again - (if* (not (eql 100 (client-request-response-code creq))) - then (return)) + + (net.aserve::maybe-accumulate-log (:xmit-client-response-headers "~s") + (loop + (if* (catch 'premature-eof + (read-client-response-headers creq + :throw-on-eof + (and connection + 'premature-eof)) + ;; if it's a continue, then start the read again + (if* (not (eql 100 (client-request-response-code creq))) + then (return)) - nil) + nil) - then ; got eof right away.. likely due to bogus - ; saved connection... so try again with - ; no saved connection - (ignore-errors (close connection)) - (setf (getf args :connection) nil) - (return-from do-http-request - (apply 'do-http-request uri args)))) + then ; got eof right away.. likely due to bogus + ; saved connection... so try again with + ; no saved connection + (ignore-errors (close connection)) + (setf (getf args :connection) nil) + (return-from do-http-request + (apply 'do-http-request uri args))))) (if* (equal "close" (cdr (assoc :connection (client-request-headers creq)))) @@ -452,6 +453,7 @@ ))) (let ((body (read-response-body creq :format format))) + (net.aserve::debug-format :xmit-client-response-body "~s" body) (if* new-location then ; must do a redirect to get to the real site (client-request-close creq) @@ -558,11 +560,12 @@ ;; bug16130: in case one was left laying around: :if-exists :supersede)) - (loop - (read-client-response-headers creq) - ;; if it's a continue, then start the read again - (if* (not (eql 100 (client-request-response-code creq))) - then (return))) + (net.aserve::maybe-accumulate-log (:xmit-client-response-headers "~s") + (loop + (read-client-response-headers creq) + ;; if it's a continue, then start the read again + (if* (not (eql 100 (client-request-response-code creq))) + then (return)))) (if* (and (member (client-request-response-code creq) redirect-codes :test #'eq) @@ -574,26 +577,27 @@ (cdr (assoc :location (client-request-headers creq) :test #'eq)))) - (loop - (if* (and timeout (numberp timeout)) - then (let ((res (sys:with-timeout (timeout :timed-out) - (setq end - (client-request-read-sequence buf creq))))) - (if* (eq :timed-out res) - then (error "~a is not responding." - (net.uri:uri-host uri)))) - else (setq end (client-request-read-sequence buf creq))) - (if* (zerop end) - then (if* progress-function - then (funcall progress-function -1 size)) - (return)) ;; EOF - (if* progress-at - then (incf bytes-read buffer-size) - (if* (> bytes-read (car progress-at)) - then (setq progress-at (cdr progress-at)) - (ignore-errors (funcall progress-function bytes-read - size)))) - (write-sequence buf s :end end)) + (net.aserve::maybe-accumulate-log (:xmit-client-response-body "~s") + (loop + (if* (and timeout (numberp timeout)) + then (let ((res (sys:with-timeout (timeout :timed-out) + (setq end + (client-request-read-sequence buf creq))))) + (if* (eq :timed-out res) + then (error "~a is not responding." + (net.uri:uri-host uri)))) + else (setq end (client-request-read-sequence buf creq))) + (if* (zerop end) + then (if* progress-function + then (funcall progress-function -1 size)) + (return)) ;; EOF + (if* progress-at + then (incf bytes-read buffer-size) + (if* (> bytes-read (car progress-at)) + then (setq progress-at (cdr progress-at)) + (ignore-errors (funcall progress-function bytes-read + size)))) + (write-sequence buf s :end end))) (setq code (client-request-response-code creq)) @@ -702,7 +706,6 @@ (ignore-errors (close connection)) ; drop into code to do it normally ))) - (let (host sock port fresh-uri scheme-default-port) ;; start a request @@ -832,149 +835,157 @@ or \"foo.com:8000\", not ~s" proxy)) query :external-format external-format) content-type "application/x-www-form-urlencoded")))) - - (net.aserve::format-dif :xmit sock "~a ~a ~a~a" - (string-upcase (string method)) - (if* (eq method :connect) - then ;; deliver 'uri' untouched - uri - else (if* proxy - then (net.uri:render-uri uri nil) - else (uri-path-etc uri))) - (string-upcase (string protocol)) - crlf) + + (let ((command (format nil "~a ~a ~a" + (string-upcase (string method)) + (if* (eq method :connect) + then ;; deliver 'uri' untouched + uri + else (if* proxy + then (net.uri:render-uri uri nil) + else (uri-path-etc uri))) + (string-upcase (string protocol))))) + (format sock "~a~a" command crlf) + (net.aserve::debug-format :xmit-client-request-command "~s" command)) ; write often to trigger error if connection closed (if* use-socket then (force-output sock)) ; always send a Host header, required for http/1.1 and a good idea ; for http/1.0 - (if* (not (eql scheme-default-port port)) - then (net.aserve::format-dif :xmit sock "Host: ~a:~a~a" host port crlf) - else (net.aserve::format-dif :xmit sock "Host: ~a~a" host crlf)) - - - ; now the headers - (if* (and keep-alive (eq protocol :http/1.0)) - then ; for http/1.1 keep alive is the default so no need - ; to express it - (net.aserve::format-dif :xmit - sock "Connection: Keep-Alive~a" crlf) - elseif (and (not keep-alive) (eq protocol :http/1.1)) - then ; request it close for us - (net.aserve::format-dif :xmit - sock "Connection: close~a" crlf)) - - - (if* accept - then (net.aserve::format-dif :xmit - sock "Accept: ~a~a" accept crlf)) - + (net.aserve::maybe-accumulate-log (:xmit-client-request-headers "~s") + (if* (not (eql scheme-default-port port)) + then (net.aserve::format-dif :xmit-client-request-headers + sock "Host: ~a:~a~a" host port crlf) + else (net.aserve::format-dif :xmit-client-request-headers + sock "Host: ~a~a" host crlf)) + + + ; now the headers + (if* (and keep-alive (eq protocol :http/1.0)) + then ; for http/1.1 keep alive is the default so no need + ; to express it + (net.aserve::format-dif :xmit-client-request-headers + sock "Connection: Keep-Alive~a" crlf) + elseif (and (not keep-alive) (eq protocol :http/1.1)) + then ; request it close for us + (net.aserve::format-dif :xmit-client-request-headers + sock "Connection: close~a" crlf)) - (if* compress - then (net.aserve::format-dif :xmit - sock "Accept-Encoding: gzip~a" crlf)) - ; some webservers (including AServe) have trouble with put/post - ; requests without a body - (if* (and (not content) (member method '(:put :post))) - then (setf content "")) - ; content can be a nil, a single vector or a list of vectors. - ; canonicalize.. - (if* (and content (atom content)) then (setq content (list content))) - - (if* content - then (let ((computed-length 0)) - (dolist (content-piece content) - (typecase content-piece - ((array character (*)) - (if* (null content-length) - then (incf computed-length - (native-string-sizeof - content-piece - :external-format external-format)))) - - ((array (unsigned-byte 8) (*)) - (if* (null content-length) - then (incf computed-length (length content-piece)))) - (t (error "Illegal content array: ~s" content-piece)))) - - (if* (null content-length) - then (setq content-length computed-length)))) - - - - (if* content-length - then (net.aserve::format-dif :xmit - sock "Content-Length: ~s~a" content-length crlf)) - - - (if* cookies - then (let ((str (compute-cookie-string uri - cookies))) - (if* str - then (net.aserve::format-dif :xmit - sock "Cookie: ~a~a" str crlf)))) - - (if* basic-authorization - then (net.aserve::format-dif :xmit sock "Authorization: Basic ~a~a" - (base64-encode - (format nil "~a:~a" - (car basic-authorization) - (cdr basic-authorization))) - crlf)) - - (if* proxy-basic-authorization - then (net.aserve::format-dif :xmit sock "Proxy-Authorization: Basic ~a~a" - (base64-encode - (format nil "~a:~a" - (car proxy-basic-authorization) - (cdr proxy-basic-authorization))) - crlf)) - - (if* (and digest-authorization - (digest-response digest-authorization)) - then ; put out digest info - (net.aserve::format-dif - :xmit sock - "Authorization: Digest username=~s, realm=~s, nonce=~s, uri=~s, qop=~a, nc=~a, cnonce=~s, response=~s~@[, opaque=~s~]~a" - (digest-username digest-authorization) - (digest-realm digest-authorization) - (digest-nonce digest-authorization) - (digest-uri digest-authorization) - (digest-qop digest-authorization) - (digest-nonce-count digest-authorization) - (digest-cnonce digest-authorization) - (digest-response digest-authorization) - (digest-opaque digest-authorization) - crlf)) - - - - - (if* user-agent - then (if* (stringp user-agent) - thenret - elseif (eq :aserve user-agent) - then (setq user-agent net.aserve::*aserve-version-string*) - elseif (eq :netscape user-agent) - then (setq user-agent "Mozilla/4.7 [en] (WinNT; U)") - elseif (eq :ie user-agent) - then (setq user-agent "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)") - else (error "Illegal user-agent value: ~s" user-agent)) - (net.aserve::format-dif :xmit - sock "User-Agent: ~a~a" user-agent crlf)) - - (if* content-type - then (net.aserve::format-dif :xmit sock "Content-Type: ~a~a" - content-type - crlf)) + (if* accept + then (net.aserve::format-dif :xmit-client-request-headers + sock "Accept: ~a~a" accept crlf)) + + + (if* compress + then (net.aserve::format-dif :xmit-client-request-headers + sock "Accept-Encoding: gzip~a" crlf)) + + ; some webservers (including AServe) have trouble with put/post + ; requests without a body + (if* (and (not content) (member method '(:put :post))) + then (setf content "")) + ; content can be a nil, a single vector or a list of vectors. + ; canonicalize.. + (if* (and content (atom content)) then (setq content (list content))) + + (if* content + then (let ((computed-length 0)) + (dolist (content-piece content) + (typecase content-piece + ((array character (*)) + (if* (null content-length) + then (incf computed-length + (native-string-sizeof + content-piece + :external-format external-format)))) + + ((array (unsigned-byte 8) (*)) + (if* (null content-length) + then (incf computed-length (length content-piece)))) + (t (error "Illegal content array: ~s" content-piece)))) + + (if* (null content-length) + then (setq content-length computed-length)))) + + + + (if* content-length + then (net.aserve::format-dif :xmit-client-request-headers + sock "Content-Length: ~s~a" content-length crlf)) - (if* headers - then (dolist (header headers) - (net.aserve::format-dif :xmit sock "~a: ~a~a" - (car header) (cdr header) crlf))) - (if* use-socket then (force-output sock)) + + (if* cookies + then (let ((str (compute-cookie-string uri + cookies))) + (if* str + then (net.aserve::format-dif :xmit-client-request-headers + sock "Cookie: ~a~a" str crlf)))) + + (if* basic-authorization + then (net.aserve::format-dif :xmit-client-request-headers + sock "Authorization: Basic ~a~a" + (base64-encode + (format nil "~a:~a" + (car basic-authorization) + (cdr basic-authorization))) + crlf)) + + (if* proxy-basic-authorization + then (net.aserve::format-dif :xmit-client-request-headers + sock "Proxy-Authorization: Basic ~a~a" + (base64-encode + (format nil "~a:~a" + (car proxy-basic-authorization) + (cdr proxy-basic-authorization))) + crlf)) + + (if* (and digest-authorization + (digest-response digest-authorization)) + then ; put out digest info + (net.aserve::format-dif + :xmit-client-request-headers sock + "Authorization: Digest username=~s, realm=~s, nonce=~s, uri=~s, qop=~a, nc=~a, cnonce=~s, response=~s~@[, opaque=~s~]~a" + (digest-username digest-authorization) + (digest-realm digest-authorization) + (digest-nonce digest-authorization) + (digest-uri digest-authorization) + (digest-qop digest-authorization) + (digest-nonce-count digest-authorization) + (digest-cnonce digest-authorization) + (digest-response digest-authorization) + (digest-opaque digest-authorization) + crlf)) + + + + + (if* user-agent + then (if* (stringp user-agent) + thenret + elseif (eq :aserve user-agent) + then (setq user-agent net.aserve::*aserve-version-string*) + elseif (eq :netscape user-agent) + then (setq user-agent "Mozilla/4.7 [en] (WinNT; U)") + elseif (eq :ie user-agent) + then (setq user-agent "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)") + else (error "Illegal user-agent value: ~s" user-agent)) + (net.aserve::format-dif :xmit-client-request-headers + sock "User-Agent: ~a~a" user-agent crlf)) + + (if* content-type + then (net.aserve::format-dif :xmit-client-request-headers + sock "Content-Type: ~a~a" + content-type + crlf)) + + (if* headers + then (dolist (header headers) + (net.aserve::format-dif :xmit-client-request-headers + sock "~a: ~a~a" + (car header) (cdr header) crlf))) + (if* use-socket then (force-output sock))) (write-string crlf sock) ; final crlf @@ -986,11 +997,14 @@ or \"foo.com:8000\", not ~s" proxy)) (if* content then ; content can be a vector a list of vectors (dolist (cont content) - (net.aserve::if-debug-action - :xmit - (format net.aserve::*debug-stream* - "client sending content of ~d characters/bytes" - (length cont))) + (net.aserve::debug-format + :info "client sending content of ~d characters/bytes" + (length cont)) + (net.aserve::debug-format + :xmit-client-request-body + "~s" (if (stringp cont) + cont + (octets-to-string cont :external-format :octets))) (write-sequence cont sock))) @@ -1042,6 +1056,8 @@ or \"foo.com:8000\", not ~s" proxy)) (throw throw-on-eof t)) (error "premature eof from server")) + (net.aserve::debug-format :xmit-client-response-headers "~a~a" + (subseq buff 0 len) crlf) (macrolet ((fail () `(let ((i 0)) (error "illegal response from web server: ~s" @@ -1185,38 +1201,36 @@ or \"foo.com:8000\", not ~s" proxy)) bytes-left))))) (if* (eq ans start) then 0 ; eof - else (net.aserve::if-debug-action :xmit - (write-sequence - buffer - net.aserve::*debug-stream* - :start start - :end - ans)) + else (net.aserve::debug-format + :xmit-client-response-body "~s" + (octets-to-string buffer :start start :end ans + :external-format :octets)) (setf (client-request-bytes-left creq) (- bytes-left (- ans start))) ans))) elseif (or (eq bytes-left :chunked) (eq bytes-left :unknown)) - then (handler-case (do ((i start (1+ i)) - (stringp (stringp buffer)) - (debug-on (member :xmit - net.aserve::*debug-current* - :test #'eq))) - ((>= i end) (setq last end)) - (setq last i) - (let ((ch (if* stringp - then (read-char socket nil nil) - else (read-byte socket nil nil)))) - (if* (null ch) - then (setf (client-request-bytes-left creq) :eof) - (return) - else (if* debug-on - then (write-char - (if* (characterp ch) - then ch - else (code-char ch)) - net.aserve::*debug-stream*)) - (setf (aref buffer i) ch)))) + then (handler-case + (do ((i start (1+ i)) + (stringp (stringp buffer)) + (debug-on (member :xmit-client-response-body + net.aserve::*debug-current* + :test #'eq))) + ((>= i end) (setq last end)) + (setq last i) + (let ((ch (if* stringp + then (read-char socket nil nil) + else (read-byte socket nil nil)))) + (if* (null ch) + then (setf (client-request-bytes-left creq) :eof) + (return) + else (if* debug-on + then (net.aserve::debug-format + :xmit-client-response-body "~a" + (if* (characterp ch) + then ch + else (code-char ch)))) + (setf (aref buffer i) ch)))) (excl::socket-chunking-end-of-file (cond) (declare (ignore cond)) diff --git a/headers.cl b/headers.cl index 4d824271..ece50de8 100644 --- a/headers.cl +++ b/headers.cl @@ -703,7 +703,10 @@ (let* ((buff (get-sresource *header-block-sresource*)) (end (read-headers-into-buffer sock buff))) (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)) else (free-sresource *header-block-sresource* buff) (error "Incomplete headers sent by server")))) diff --git a/log.cl b/log.cl index a3986848..d24c1c05 100644 --- a/log.cl +++ b/log.cl @@ -35,6 +35,29 @@ (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 @@ -43,21 +66,27 @@ (log-for-wserver *wserver* message format)) (defmethod log-for-wserver ((wserver wserver) message format) - ;; send log message to the default vhost's error stream - (logmess-stream message (vhost-error-stream (wserver-default-vhost wserver)) 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 (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 ;; 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)) + (decode-universal-time (get-universal-time) *log-time-zone*) (let* ((*print-pretty* nil) (str (ecase format (:long (format - nil "~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%" - (mp:process-name sys:*current-process*) + 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 @@ -72,51 +101,11 @@ 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 (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)))) - - (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))))) - + 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)) @@ -133,15 +122,49 @@ (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*)) - - - ) + (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 @@ -158,7 +181,3 @@ else (net.uri:render-uri uri nil)) extra) :brief)) - - - - diff --git a/main.cl b/main.cl index 57f1bab4..4cf611d9 100644 --- a/main.cl +++ b/main.cl @@ -55,105 +55,260 @@ (cadr *aserve-version*) (caddr *aserve-version*))) -;;;;;;; debug support +;;;;;;; debug support + +;; An alist of kind and the superkinds it belongs to. +(defparameter *debug-kinds* ()) -(defparameter *debug-all* nil) ; all of the debugging switches -(defparameter *debug-log* nil) ; all debugging switches that write info - ; to the *debug-stream* (defparameter *debug-current* nil) ; current switches set (defparameter *debug-stream* *initial-terminal-io*) +(defparameter *debug-format* :long) + ; set to true to automatically close sockets about to be gc'ed ; open sockets should never be subject to gc unless there's a bug ; in the code leading to leaks. -(defvar *watch-for-open-sockets* t) +(defvar *watch-for-open-sockets* t) -(defmacro define-debug-kind (name class what) - `(progn (ecase ,class - (:all (pushnew ,name *debug-all*)) - (:log (pushnew ,name *debug-log*) - (pushnew ,name *debug-all*))) - (setf (get ,name 'debug-description) ,what))) +(defun find-kind-entry (kind) + (find kind *debug-kinds* :key #'car)) -(define-debug-kind :notrap :all - "If set than errors in handlers cause a break loop to be entered") +(defun add-new-kind (kind superkinds documentation) + (if* (find-kind-entry kind) + then (error "Debug kind ~s already defined." kind)) + (dolist (superkind superkinds) + (if* (null (find-kind-entry superkind)) + then (error "Can't find superkind ~s for ~s." superkind kind))) + (push (cons kind superkinds) *debug-kinds*) + (setf (get kind 'debug-description) documentation)) -(define-debug-kind :xmit :log - "If set then most of the traffic between clients and servers is also sent to the debug stream") +(defmacro define-debug-kind (kind superkinds documentation) + `(add-new-kind ,kind ',superkinds ,documentation)) -(define-debug-kind :info :log - "General information") +(define-debug-kind :all () + "The mother of all debug features.") -(define-debug-kind :zoom-on-error :all - "If set then print a zoom to the vhost-error-stream when an error occurs in a handler") - +(define-debug-kind :notrap (:all) + "If set than errors in handlers cause a break loop to be entered.") + +(define-debug-kind :zoom-on-error (:all) + "If set then print a zoom to the vhost-error-stream when an error occurs in a handler.") + +(define-debug-kind :log (:all) + "Category of features that write some kind of log.") + +(define-debug-kind :xmit (:log) + "Category of features that log the traffic between clients, servers.") + +(define-debug-kind :info (:log) + "General information.") + +(define-debug-kind :client (:all) + "Category of features that log client communication.") + +(define-debug-kind :server (:all) + "Category of features that log server communication.") + +(define-debug-kind :proxy (:all) + "Category of features that log proxy communication.") + +(define-debug-kind :request (:all) + "Category of features that log requests.") + +(define-debug-kind :response (:all) + "Category of features that log responses.") + +(define-debug-kind :command (:all) + "Category of features that log http request commands.") + +(define-debug-kind :headers (:all) + "Category of features that log request/response headers.") + +(define-debug-kind :body (:all) + "Category of features that log request/response bodies.") + + +(define-debug-kind :xmit-client-request-command + (:xmit :client :request :command) + "If set then print the client request commands.") + +(define-debug-kind :xmit-client-request-headers + (:xmit :client :request :headers) + "If set then print the client request headers.") + +(define-debug-kind :xmit-client-request-body + (:xmit :client :request :body) + "If set then print the client request bodies.") + +(define-debug-kind :xmit-client-response-headers + (:xmit :client :response :headers) + "If set then print the client response headers.") + +(define-debug-kind :xmit-client-response-body + (:xmit :client :response :body) + "If set then print the client response bodies.") + + +(define-debug-kind :xmit-server-request-command + (:xmit :server :request :command) + "If set then print the server request commands.") + +(define-debug-kind :xmit-server-request-headers + (:xmit :server :request :headers) + "If set then print the server request headers.") + +(define-debug-kind :xmit-server-request-body + (:xmit :server :request :body) + "If set then print the server request bodies.") + +(define-debug-kind :xmit-server-response-headers + (:xmit :server :response :headers) + "If set then print the server response headers.") + +(define-debug-kind :xmit-server-response-body + (:xmit :server :response :body) + "If set then print the server response bodies.") + +;; These are parallell to the client and server kinds, from the point +;; of view of the proxy. That is, :xmit-proxy-client-request-command +;; is what the proxy sends on as a client to the real server. + +(define-debug-kind :xmit-proxy-client-request-command + (:xmit :proxy :client :request :command) + "If set then print the proxy request command sent to the real server.") + +(define-debug-kind :xmit-proxy-client-request-headers + (:xmit :proxy :client :request :headers) + "If set then print the proxy request headers sent to the real server.") + +(define-debug-kind :xmit-proxy-client-request-body + (:xmit :proxy :client :request :body) + "If set then print the proxy request bodies sent to the real server.") + +(define-debug-kind :xmit-proxy-client-response-headers + (:xmit :proxy :client :response :headers) + "If set then print the proxy response headers sent by the real server.") + +(define-debug-kind :xmit-proxy-client-response-body + (:xmit :proxy :client :response :body) + "If set then print the proxy response bodies sent by the real server.") + +;; What the proxy as a server sends to the real client. Note there are +;; no :xmit-proxy-server-request-* kinds, 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-*. + +(define-debug-kind :xmit-proxy-server-response-headers + (:xmit :proxy :server :response :headers) + "If set then print the proxy response headers sent to the client.") + +(define-debug-kind :xmit-proxy-server-response-body + (:xmit :proxy :server :response :body) + "If set then print the proxy response bodies sent by the client.") + +(defun expand-kinds (kinds) + (dolist (kind kinds) + (if* (null (find-kind-entry kind)) + then (error "Can't find kind ~s." kind))) + (let ((kinds kinds)) + (loop for entry in (reverse *debug-kinds*) + do (destructuring-bind (kind &rest superkinds) entry + (when (intersection superkinds kinds) + (pushnew kind kinds)))) + kinds)) (defun debug-on (&rest args) ;; add the given debug kinds to the log list (if* (null args) then (note-debug-set) - else (dolist (arg args) - (case arg - (:all (setq *debug-current* *debug-all*)) - (:log (setq *debug-current* - (union *debug-current* *debug-log*))) - (t (pushnew arg *debug-current*)))))) + else (setq *debug-current* + (union *debug-current* (expand-kinds args))))) (defun debug-off (&rest args) ;; turn off the debugging (if* (null args) then (note-debug-set) - else (dolist (arg args) - (case arg - (:all (setq *debug-current* nil)) - (:log (setq *debug-current* - (set-difference *debug-current* *debug-log*))) - (t (setq *debug-current* (remove arg *debug-current*))))))) + else (setq *debug-current* + (set-difference *debug-current* (expand-kinds args))))) (defun note-debug-set () ;; describe what debugging switches exist and if they are on ;; and off - (dolist (kind *debug-all*) - (format t "~7s ~4a ~a~%" - kind - (if* (member kind *debug-current*) - then "on" - else "off") - (get kind 'debug-description)))) + (dolist (entry (reverse *debug-kinds*)) + (destructuring-bind (kind &rest superkinds) entry + (format t "~40s ~4a~% ~a~%~a" + kind + (if* (member kind *debug-current*) + then "on" + else "off") + (get kind 'debug-description) + (if* superkinds + then (format nil " (parent categories: ~{~s~^, ~})~%" + superkinds) + else ""))))) + + +(defun format-debug-message (kind stream format args) + (declare (ignore kind)) + (apply #'format stream format args)) - - -(defmacro debug-format (kind &rest args) - ;; do the format to *debug-stream* if the kind of this info - ;; is matched by the value of *debug-current* +(defmacro if-debug-action (kind &body body) + ;; only do if the debug value is high enough `(if* (member ,kind *debug-current* :test #'eq) - then (write-sequence - (concatenate 'string - (format nil "d> (~a): " (mp:process-name sys:*current-process*)) - (format nil ,@args)) - *debug-stream*))) + then ,@body)) + +;; An alist that maps debug kinds to streams. See +;; maybe-accumulate-log. +(defvar *accumulating-kinds-and-streams* ()) +(defun accumulator-stream-for-kind (kind) + (cdr (assoc kind *accumulating-kinds-and-streams*))) -(defmacro format-dif (debug-key &rest args) +(defmacro debug-format (kind format &rest args) + ;; do the format to *debug-stream* if the kind of this info + ;; is matched by the value of *debug-current* + `(if-debug-action ,kind + (let ((accumulator-stream (accumulator-stream-for-kind ,kind))) + (if accumulator-stream + (format accumulator-stream ,format ,@args) + (log1 ,kind :info (format-debug-message ,kind nil ,format + (list ,@args))))))) + +(defmacro maybe-accumulate-log ((debug-action sink) &body body) + (let ((debug-output-stream (gensym "debug-output-stream")) + (tag (gensym "tag")) + (%sink (gensym "sink"))) + `(flet ((body () + ,@body)) + (let ((,%sink ,sink)) + (catch ',tag + (or (if-debug-action ,debug-action + (with-output-to-buffer (,debug-output-stream) + (unwind-protect + (let ((*accumulating-kinds-and-streams* + (or (if-debug-action ,debug-action + (cons (cons ,debug-action + ,debug-output-stream) + *accumulating-kinds-and-streams*)) + *accumulating-kinds-and-streams*))) + (throw ',tag (body))) + (let ((string (multiple-value-bind (buffer length) + (get-output-stream-buffer + ,debug-output-stream) + (octets-to-string + buffer :end length + :external-format :octets)))) + (if (functionp ,%sink) + (funcall ,%sink string) + (debug-format ,debug-action ,%sink string)))))) + (body))))))) + +(defmacro format-dif (kind &rest args) ;; do the format and also do the same format to the ;; debug stream if the given debug keyword is set - ;; do the format and then send to *initial-terminal-io* `(progn (format ,@args) - (if* (member ,debug-key *debug-current* :test #'eq) - then ; do extra consing to ensure that it all be written out - ; at once - (write-sequence - (concatenate 'string - (format nil "x>(~a): " - (mp:process-name sys:*current-process*)) - (format nil ,@(cdr args))) - *debug-stream*)))) - -(defmacro if-debug-action (kind &body body) - ;; only do if the debug value is high enough - `(progn (if* (member ,kind *debug-current* :test #'eq) - then ,@body))) + (debug-format ,kind ,@(cdr args)))) (defun check-for-open-socket-before-gc (socket) (if* (open-stream-p socket) @@ -283,6 +438,13 @@ :initform nil :accessor wserver-filters) + (logger + ;; on opaque object that's passed to log1* on which it can + ;; dispatch + :initarg :logger + :initform t + :accessor wserver-logger) + (log-function ;; function to call after the request is done to ;; do the logging @@ -530,6 +692,16 @@ External-format `~s' passed to make-http-client-request filters line endings. Problems with protocol may occur." (ef-name ef))))) +(defun check-external-format (external-format) + (declare (ignorable external-format)) + #+(and allegro (version>= 6 0 pre-final 1)) + (if* (and (streamp *html-stream*) + (not (eq external-format + (stream-external-format *html-stream*)))) + then (warn-if-crlf external-format) + (setf (stream-external-format *html-stream*) + external-format))) + (defmacro with-http-body ((req ent &key headers (external-format @@ -540,7 +712,7 @@ Problems with protocol may occur." (ef-name ef))))) (g-ent (gensym)) (g-headers (gensym)) (g-external-format (gensym)) - ) + (g-old-request-reply-stream (gensym))) `(let ((,g-req ,req) (,g-ent ,ent) (,g-headers ,headers) @@ -556,16 +728,26 @@ Problems with protocol may occur." (ef-name ef))))) then (bulk-set-reply-headers ,g-req ,g-headers)) (send-response-headers ,g-req ,g-ent :pre) (if* (not (member :omit-body (request-reply-strategy ,g-req) - :test #'eq)) - then (let ((*html-stream* (request-reply-stream ,g-req))) - #+(and allegro (version>= 6 0 pre-final 1)) - (if* (and (streamp *html-stream*) - (not (eq ,g-external-format - (stream-external-format *html-stream*)))) - then (warn-if-crlf ,g-external-format) - (setf (stream-external-format *html-stream*) - ,g-external-format)) - (progn ,@body))) + :test #'eq)) + then (if* (member :xmit-server-response-body *debug-current*) + then (maybe-accumulate-log (:xmit-server-response-body "~s") + (let ((,g-old-request-reply-stream + (request-reply-stream ,g-req))) + (unwind-protect + (let ((*html-stream* + (make-broadcast-stream + (accumulator-stream-for-kind + :xmit-server-response-body) + (request-reply-stream ,g-req)))) + (check-external-format ,g-external-format) + (setf (request-reply-stream ,g-req) + *html-stream*) + ,@body) + (setf (request-reply-stream ,g-req) + ,g-old-request-reply-stream)))) + else (let ((*html-stream* (request-reply-stream ,g-req))) + (check-external-format ,g-external-format) + ,@body))) (if* (member :keep-alive (request-reply-strategy ,g-req) :test #'eq) then ; force the body to be read so we can continue @@ -1207,6 +1389,21 @@ by keyword symbols and not by strings" nil))) (close main-socket)))) +;; Bound to wserver-logger if that's set when logging for a particular +;; wserver. Log messages coming from the client use the global value. +(defvar *logger* nil) + +(defun initial-bindings () + #+(version>= 9 0 :alpha 44) + `((*wserver* . ',*wserver*) + (*logger* . ',(or (wserver-logger *wserver*) + *logger*)) + ,@excl:*required-top-level-bindings*) + #-(version>= 9 0 :alpha 44) + `((*wserver* . ',*wserver*) + (*logger* . ',(or (wserver-logger *wserver*) + *logger*)) + ,@excl:*cl-default-special-bindings*)) (defun start-lisp-thread-server (listeners) ;; start a server that consists of a set of lisp threads for @@ -1226,13 +1423,7 @@ by keyword symbols and not by strings" then (wserver-name *wserver*) else "aserve") (atomic-incf *thread-index*)) - :initial-bindings - #+(version>= 9 0 :alpha 44) - `((*wserver* . ',*wserver*) - ,@excl:*required-top-level-bindings*) - #-(version>= 9 0 :alpha 44) - `((*wserver* . ',*wserver*) - ,@excl:*cl-default-special-bindings*)) + :initial-bindings (initial-bindings)) #'http-accept-thread))) ;; make-worker-thread wasn't thread-safe before smp. I'm assuming that's @@ -1246,14 +1437,7 @@ by keyword symbols and not by strings" then (wserver-name *wserver*) else "aserve"))) (proc (mp:make-process :name name - :initial-bindings - #+(version>= 9 0 :alpha 44) - `((*wserver* . ',*wserver*) - ,@excl:*required-top-level-bindings*) - #-(version>= 9 0 :alpha 44) - `((*wserver* . ',*wserver*) - ,@excl:*cl-default-special-bindings*) - ))) + :initial-bindings (initial-bindings)))) (mp:process-preset proc #'http-worker-thread) (push proc (wserver-worker-threads *wserver*)) (enqueue (wserver-free-worker-threads *wserver*) proc) @@ -1500,7 +1684,7 @@ by keyword symbols and not by strings" (multiple-value-setq (req error-obj) (ignore-errors (with-timeout-local ((wserver-read-request-timeout *wserver*) - (debug-format :info "request timed out on read~%") + (debug-format :info "request timed out on read") (return-from process-connection nil)) (read-http-request sock chars-seen)))) @@ -1537,8 +1721,8 @@ by keyword symbols and not by strings" (setf (request-reply-date req) (get-universal-time)) (force-output-noblock (request-socket req)) - - (log-request req) + + (log-request req) (setq *worker-request* nil) (free-req-header-block req) @@ -1548,7 +1732,7 @@ by keyword symbols and not by strings" (request-reply-strategy req) :test #'eq) then ; continue to use it - (debug-format :info "request over, keep socket alive~%") + (debug-format :info "request over, keep socket alive") (force-output-noblock sock) (setf (car chars-seen) nil) ; for next use (excl::socket-bytes-written (request-socket req) 0) @@ -1599,16 +1783,13 @@ by keyword symbols and not by strings" (debug-format :info "got line of size ~d: " end) - (if-debug-action :info - (dotimes (i end) (write-char (schar buffer i) - *initial-terminal-io*)) - (terpri *initial-terminal-io*) (force-output *initial-terminal-io*)) - - (if* (not (eql 0 end)) + + (if* (not (eql 0 end)) then (return) ; out of loop )) (setq raw-cmd (buffer-substr buffer 0 end)) + (debug-format :xmit-server-request-command "~s" raw-cmd) (multiple-value-bind (cmd uri protocol) (parse-http-command buffer end) @@ -1644,7 +1825,7 @@ by keyword symbols and not by strings" #+ignore (null (read-request-headers req sock buffer)) (null (new-read-request-headers req sock)) ) - then (debug-format :info "no headers, ignore~%") + then (debug-format :info "no headers, ignore") (return-from read-http-request nil)) ; insert the host name and port into the uri @@ -1719,7 +1900,7 @@ by keyword symbols and not by strings" ;; cache it for later too (or (request-request-body req) (setf (request-request-body req) - (get-request-body-retrieve req))))) + (get-request-body-retrieve-and-maybe-log req))))) (if* (and ef-supplied result) ; spr27296 then (values (octets-to-string @@ -1727,6 +1908,10 @@ by keyword symbols and not by strings" :external-format external-format)) else result))) +(defun get-request-body-retrieve-and-maybe-log (req) + (let ((body (get-request-body-retrieve req))) + (debug-format :xmit-server-request-body "~s" body) + body)) (defun get-request-body-retrieve (req) ;; get the guts of the body into a string. @@ -2045,11 +2230,10 @@ by keyword symbols and not by strings" (if* (<= pos end) then ; no bytes read, eof nil - else - (if-debug-action - :xmit - (format t "~%multipart read ~d bytes~%" - (- pos end)) + else (debug-format :info "multipart read ~d bytes" + (- pos end)) + (if-debug-action :xmit + (do ((i end (1+ i))) ((>= i pos)) (write-char (code-char (aref mpbuffer i)))) @@ -2493,7 +2677,7 @@ in get-multipart-sequence")) (loop (let ((ch (read-char sock nil :eof))) (if* (eq ch :eof) - then (debug-format :info"eof on socket~%") + then (debug-format :info "eof on socket") (free-request-buffer buffer) (return-from read-sock-line nil)) @@ -2505,16 +2689,7 @@ in get-multipart-sequence")) then (decf start) ; back up to toss out return ) (setf (schar buffer start) #\null) ; null terminate - - ; debug output - ; dump out buffer - (debug-format :info "read on socket: ") - (if-debug-action :info - (dotimes (i start) - (write-char (schar buffer i) *initial-terminal-io*)) - (terpri *initial-terminal-io*)) - ;; end debug - + (return-from read-sock-line (values buffer start)) else ; store character (if* (>= start max) diff --git a/packages.cl b/packages.cl index 26b3f070..f97be4c5 100644 --- a/packages.cl +++ b/packages.cl @@ -20,7 +20,8 @@ v11: 1.3.11: fix log reporting of content-length when using keep-alive. v12: 1.3.12: make aserve compatible with patch inflate.003, request-query cache includes external-format as a key, send cookies on one line as per rfc6265, - add support for ssl CRLs." + add support for ssl CRLs. +v13: 1.3.13: improve debugging facilities." :type :system :post-loadable t) diff --git a/parse.cl b/parse.cl index 338c510a..91ff9981 100644 --- a/parse.cl +++ b/parse.cl @@ -182,22 +182,25 @@ ;; return nil if we don't get all the way to the crlf crlf (let ((buff (get-sresource *header-block-sresource*)) (end)) - + (setf (request-header-block req) buff) ;; read in all the headers, stop at the last crlf (if* (setq end (read-headers-into-buffer sock buff)) - then (let ((otherheaders (parse-header-block buff 0 end))) + then (debug-format :xmit-server-request-headers "~s" + (octets-to-string buff :end end + :external-format :octets)) + (let ((otherheaders (parse-header-block buff 0 end))) - (if* otherheaders - then ; non standard headers present...store - ; separately - (dolist (otherheader otherheaders) - (setf (car otherheader) - (header-keywordify (car otherheader)))) - - (setf (request-headers req) - (append (request-headers req) otherheaders)))) - + (if* otherheaders + then ; non standard headers present...store + ; separately + (dolist (otherheader otherheaders) + (setf (car otherheader) + (header-keywordify (car otherheader)))) + + (setf (request-headers req) + (append (request-headers req) otherheaders)))) + t))) (defvar *headername-to-kwd* nil) @@ -234,8 +237,7 @@ ;; (let ((len (- (length buff) 500)) ; leave space for index at end (i 0) - (state 2) - (echo (member :xmit *debug-current*))) + (state 2)) (loop (if* (>= i len) @@ -289,10 +291,6 @@ (if* (not (eq (aref buff i) #.(char-code #\return))) then (incf i))) ; i points to the [cr] lf - (if* echo - then (write-sequence buff *debug-stream* - :start 0 - :end i)) (return i)))))) diff --git a/proxy.cl b/proxy.cl index 4a5752af..47a1217d 100644 --- a/proxy.cl +++ b/proxy.cl @@ -506,18 +506,6 @@ cached connection = ~s~%" cond cached-connection)) (setq outend (add-trailing-crlf outbuf 1)) - (if-debug-action :xmit - (format *debug-stream* "proxy converted headers toward server~%") - (dotimes (i outend) - (write-char (code-char (aref outbuf i)) *debug-stream*)) - (format *debug-stream* "---- end---~%") - (force-output *debug-stream*)) - - - - - - ; time to make a call to the server (handler-case (multiple-value-setq (sock cached-connection) @@ -555,6 +543,7 @@ cached connection = ~s~%" cond cached-connection)) (let ((firstbuf (get-header-block)) (ind 0) + rest-of-headers-ind (cmdstrings '((:get . #.(make-array 3 :element-type '(unsigned-byte 8) @@ -615,7 +604,7 @@ cached connection = ~s~%" cond cached-connection)) (setf (ausb8 firstbuf i) (char-int (schar str i)))) (incf ind (length str)))) - + (setf (ausb8 firstbuf ind) #.(char-int #\space)) (incf ind) @@ -649,26 +638,32 @@ cached connection = ~s~%" cond cached-connection)) (setf (ausb8 firstbuf ind) #.(char-int #\linefeed)) (incf ind) + (debug-format :xmit-proxy-client-request-command "~s" + (octets-to-string firstbuf :end ind + :external-format :octets)) + (setq rest-of-headers-ind ind) ; now add as much of the headers as we can (do ((i 0 (1+ i)) (tocopy (min (- (length firstbuf) ind) outend))) ((>= i tocopy) - - ; - (if-debug-action - :xmit - (format *debug-stream* "about to send~%") - (dotimes (i ind) - (write-char (code-char (ausb8 firstbuf i)) - *debug-stream*)) - (format *debug-stream* "~%")) - (write-sequence firstbuf sock :end ind) - (if* (< i outend) - then ; still more from original buffer left - (write-sequence outbuf sock - :start i - :end outend)) + + (maybe-accumulate-log (:xmit-proxy-client-request-headers "~s") + (debug-format :xmit-proxy-client-request-headers "~a" + (octets-to-string firstbuf + :start rest-of-headers-ind + :end ind + :external-format :octets)) + (write-sequence firstbuf sock :end ind) + (if* (< i outend) + then ; still more from original buffer left + (debug-format :xmit-proxy-client-request-headers "~a" + (octets-to-string + outbuf :start i :end outend + :external-format :octets)) + (write-sequence outbuf sock + :start i + :end outend))) ) (setf (ausb8 firstbuf ind) (ausb8 outbuf i)) @@ -678,10 +673,12 @@ cached connection = ~s~%" cond cached-connection)) - ; now the body if any (if* request-body - then (write-sequence request-body sock)) + then (debug-format :xmit-proxy-client-request-body "~s" + (octets-to-string request-body + :external-format :octets)) + (write-sequence request-body sock)) (force-output sock) @@ -696,6 +693,9 @@ cached connection = ~s~%" cond cached-connection)) ; ; now read the response and the following headers (setq outend (read-headers-into-buffer sock outbuf)) + (debug-format :xmit-proxy-client-response-headers "~s" + (octets-to-string outbuf :end outend + :external-format :octets)) (if* (null outend) then ; response coming back was truncated @@ -790,23 +790,22 @@ cached connection = ~s~%" cond cached-connection)) (setq cliend (add-trailing-crlf clibuf 2)) - - (if-debug-action - :xmit - (format *debug-stream* "~%~%proxy converted headers toward client~%") - (dotimes (i cliend) - (write-char (code-char (aref clibuf i)) - *debug-stream*)) - (format *debug-stream* "---- end---~%") - (force-output *debug-stream*)) - ; do the response (setq state :post-send) (if* respond then (ignore-errors (let ((rsock (request-socket req))) - + + (debug-format + :xmit-proxy-server-response-headers + "~s" + (concatenate 'string + (format nil "HTTP/1.1 ~d ~a~a" response + (and comment (octets-to-string comment)) *crlf*) + (octets-to-string clibuf :end cliend + :external-format :octets))) + (format rsock "HTTP/1.1 ~d ~a~a" response (and comment (octets-to-string comment)) *crlf*) (write-sequence clibuf rsock :end cliend) @@ -977,11 +976,15 @@ cached connection = ~s~%" cond cached-connection)) (defun write-body-buffers (sock buffers length) ;; write all the data in the buffers to the socket (if* (> length 0) - then (let ((len (if* buffers then (length (car buffers))))) - (dolist (buff buffers) - (write-sequence buff sock :end (min length len)) - (decf length len) - (if* (<= length 0) then (return)))))) + then (maybe-accumulate-log (:xmit-proxy-server-response-body "~s") + (let ((len (if* buffers then (length (car buffers))))) + (dolist (buff buffers) + (debug-format :xmit-proxy-server-response-body "~a" + (octets-to-string buff :end (min length len) + :external-format :octets)) + (write-sequence buff sock :end (min length len)) + (decf length len) + (if* (<= length 0) then (return))))))) (defun proxy-failure-response (req ent) diff --git a/publish.cl b/publish.cl index a08140b5..2850a023 100644 --- a/publish.cl +++ b/publish.cl @@ -1692,7 +1692,7 @@ (forbidden) (redirect-kind *response-temporary-redirect*) ) - (debug-format :info "directory request for ~s~%" realname) + (debug-format :info "directory request for ~s" realname) ; we can't allow the brower to specify a url with ; any ..'s in it as that would allow the browser to @@ -2223,7 +2223,7 @@ then ; send back a message that it is already ; up to date (let ((nm-ent *not-modified-entity*)) - (debug-format :info "entity is up to date~%") + (debug-format :info "entity is up to date") ; recompute strategy based on simple 0 length ; thing to return (compute-strategy req nm-ent nil) @@ -2390,7 +2390,7 @@ ;; save it - (debug-format :info "strategy is ~s~%" strategy) + (debug-format :info "strategy is ~s" strategy) (setf (request-reply-strategy req) strategy) )) @@ -2411,7 +2411,7 @@ else '(:use-socket-stream))) else (setq strategy (call-next-method))) - (debug-format :info "file strategy is ~s~%" strategy) + (debug-format :info "file strategy is ~s" strategy) (setf (request-reply-strategy req) strategy))) @@ -2433,9 +2433,6 @@ - - - (defmethod send-response-headers ((req http-request) (ent entity) time) ;; ;; called twice (from with-http-body) in the generation of a response @@ -2451,219 +2448,221 @@ (with-timeout-local (60 (logmess "timeout during header send") ;;(setf (request-reply-keep-alive req) nil) (throw 'with-http-response nil)) - (with-standard-io-syntax - (let* ((sock (request-socket req)) - (hsock) ; to send headers - (reply-stream (request-reply-stream req)) - (strategy (request-reply-strategy req)) - (extra-headers (request-reply-headers req)) - (post-headers (member :post-headers strategy :test #'eq)) - (content) - (*print-readably* nil) ; set by w-s-io-syntax and not desired - (chunked-p (member :chunked strategy :test #'eq)) - (compress (let ((ent (member :compress strategy :test #'eq))) - (cadr ent) ; will be :gzip or :deflate or nil - )) - (code (request-reply-code req)) - (send-headers - (if* post-headers - then (eq time :post) - else (eq time :pre)) - ) - (sos-ef) ; string output stream external format - ;(ssl-p (wserver-ssl *wserver*)) - ) - + (maybe-accumulate-log (:xmit-server-response-headers + (lambda (string) + (log1 :xmit-server-response-headers :info + (list time string)))) + (with-standard-io-syntax + (let* ((sock (request-socket req)) + (hsock) ; to send headers + (reply-stream (request-reply-stream req)) + (strategy (request-reply-strategy req)) + (extra-headers (request-reply-headers req)) + (post-headers (member :post-headers strategy :test #'eq)) + (content) + (*print-readably* nil) ; set by w-s-io-syntax and not desired + (chunked-p (member :chunked strategy :test #'eq)) + (compress (let ((ent (member :compress strategy :test #'eq))) + (cadr ent) ; will be :gzip or :deflate or nil + )) + (code (request-reply-code req)) + (send-headers + (if* post-headers + then (eq time :post) + else (eq time :pre)) + ) + (sos-ef) ; string output stream external format + ;(ssl-p (wserver-ssl *wserver*)) + ) + - - (setq hsock sock) - (if* (and send-headers (member :delay-headers strategy :test #'eq)) - then ; must capture the headers in a string output stream - (setq hsock (make-string-output-stream))) - - - (if* send-headers - then (format-dif :xmit hsock "~a ~d ~a~a" - (request-reply-protocol-string req) - (response-number code) - (response-desc code) - *crlf*)) - - (if* (and post-headers - (eq time :post) - (member :string-output-stream strategy :test #'eq) - ) - then ; must get data to send from the string output stream - (setq content - (if* (request-reply-stream req) - then (setq sos-ef (stream-external-format - (request-reply-stream req))) - (get-output-stream-string - (request-reply-stream req)) - - else ; no stream created since no body given - "")) - - (if* (and sos-ef (not (eq (stream-external-format sock) sos-ef))) - then ; must do ext format conversion now - ; so we can compute the length - (setq content - (string-to-octets content :external-format sos-ef - :null-terminate nil))) - - (setf (request-reply-content-length req) (length content))) - - (if* (and send-headers - (not (eq (request-protocol req) :http/0.9))) - then ; can put out headers - (format-dif :xmit hsock "Date: ~a~a" - (maybe-universal-time-to-date (request-reply-date req)) - *crlf*) - - (if* (member :keep-alive strategy :test #'eq) - then (format-dif :xmit - hsock "Connection: Keep-Alive~aKeep-Alive: timeout=~d~a" - *crlf* - (wserver-read-request-timeout *wserver*) - *crlf*) - else (format-dif :xmit hsock "Connection: Close~a" *crlf*)) - - (if* (not (assoc :server extra-headers :test #'eq)) - then ; put out default server info - (format-dif :xmit hsock "Server: AllegroServe/~a~a" - *aserve-version-string* - *crlf*)) - - (if* (request-reply-content-type req) - then (format-dif :xmit - hsock "Content-Type: ~a~a" - (request-reply-content-type req) - *crlf*)) - - (if* chunked-p - then (format-dif :xmit - hsock "Transfer-Encoding: chunked~a" - *crlf*)) - - (if* compress - then (format-dif :xmit - hsock "Content-Encoding: ~a~a" - compress - *crlf*)) - - (if* (and (not chunked-p) - (request-reply-content-length req)) - then (format-dif :xmit hsock "Content-Length: ~d~a" - (request-reply-content-length req) - *crlf*) - (debug-format :info - "~d ~s - ~d bytes~%" - (response-number code) - (response-desc code) - (request-reply-content-length req)) - elseif chunked-p - then (debug-format :info "~d ~s - chunked~%" - (response-number code) - (response-desc code) - ) - else (debug-format :info - "~d ~s - unknown length~%" - (response-number code) - (response-desc code) - )) - - (dolist (head (request-reply-headers req)) - (format-dif :xmit hsock "~a: ~a~a" - (car head) - (cdr head) - *crlf*)) - (format-dif :xmit hsock "~a" *crlf*) - - (force-output hsock) - ; clear bytes written count so we can count data bytes - ; transferred - #+(and allegro (version>= 6)) - (excl::socket-bytes-written hsock 0) - ) - - (if* (and send-headers (member :delay-headers strategy :test #'eq)) - then ; headers are now in a string output stream - - - (let ((header-content - (string-to-octets - (get-output-stream-string hsock) - :null-terminate nil - :external-format :octets - ))) - - (setq reply-stream - (setf (request-reply-stream req) - (make-instance 'prepend-stream - :content header-content - :output-handle reply-stream))))) - - - - - (if* (and send-headers chunked-p (eq time :pre)) - then (force-output hsock) - ; do chunking - (setq reply-stream - (make-instance 'chunking-stream - :output-handle reply-stream)) - (setf (request-reply-stream req) - reply-stream)) - - - + + (setq hsock sock) + (if* (and send-headers (member :delay-headers strategy :test #'eq)) + then ; must capture the headers in a string output stream + (setq hsock (make-string-output-stream))) + + + (if* send-headers + then (format-dif :xmit-server-response-headers hsock "~a ~d ~a~a" + (request-reply-protocol-string req) + (response-number code) + (response-desc code) + *crlf*)) + + (if* (and post-headers + (eq time :post) + (member :string-output-stream strategy :test #'eq) + ) + then ; must get data to send from the string output stream + (setq content + (if* (request-reply-stream req) + then (setq sos-ef (stream-external-format + (request-reply-stream req))) + (get-output-stream-string + (request-reply-stream req)) + + else ; no stream created since no body given + "")) + + (if* (and sos-ef (not (eq (stream-external-format sock) sos-ef))) + then ; must do ext format conversion now + ; so we can compute the length + (setq content + (string-to-octets content :external-format sos-ef + :null-terminate nil))) + + (setf (request-reply-content-length req) (length content))) + + (if* (and send-headers + (not (eq (request-protocol req) :http/0.9))) + then ; can put out headers + (format-dif :xmit-server-response-headers hsock "Date: ~a~a" + (maybe-universal-time-to-date (request-reply-date req)) + *crlf*) + + (if* (member :keep-alive strategy :test #'eq) + then (format-dif :xmit-server-response-headers + hsock "Connection: Keep-Alive~aKeep-Alive: timeout=~d~a" + *crlf* + (wserver-read-request-timeout *wserver*) + *crlf*) + else (format-dif :xmit-server-response-headers + hsock "Connection: Close~a" *crlf*)) + + (if* (not (assoc :server extra-headers :test #'eq)) + then ; put out default server info + (format-dif :xmit-server-response-headers + hsock "Server: AllegroServe/~a~a" + *aserve-version-string* + *crlf*)) + + (if* (request-reply-content-type req) + then (format-dif :xmit-server-response-headers + hsock "Content-Type: ~a~a" + (request-reply-content-type req) + *crlf*)) + + (if* chunked-p + then (format-dif :xmit-server-response-headers + hsock "Transfer-Encoding: chunked~a" + *crlf*)) + + (if* compress + then (format-dif :xmit-server-response-headers + hsock "Content-Encoding: ~a~a" + compress + *crlf*)) + + (if* (and (not chunked-p) + (request-reply-content-length req)) + then (format-dif :xmit-server-response-headers + hsock "Content-Length: ~d~a" + (request-reply-content-length req) + *crlf*) + (debug-format :info + "~d ~s - ~d bytes" + (response-number code) + (response-desc code) + (request-reply-content-length req)) + elseif chunked-p + then (debug-format :info "~d ~s - chunked" + (response-number code) + (response-desc code) + ) + else (debug-format :info + "~d ~s - unknown length" + (response-number code) + (response-desc code) + )) + + (dolist (head (request-reply-headers req)) + (format-dif :xmit-server-response-headers + hsock "~a: ~a~a" + (car head) + (cdr head) + *crlf*)) + (format hsock "~a" *crlf*) + (force-output hsock) + ; clear bytes written count so we can count data bytes + ; transferred + #+(and allegro (version>= 6)) + (excl::socket-bytes-written hsock 0) + ) + + (if* (and send-headers (member :delay-headers strategy :test #'eq)) + then ; headers are now in a string output stream + + + (let ((header-content + (string-to-octets + (get-output-stream-string hsock) + :null-terminate nil + :external-format :octets + ))) + + (setq reply-stream + (setf (request-reply-stream req) + (make-instance 'prepend-stream + :content header-content + :output-handle reply-stream))))) + + + + + (if* (and send-headers chunked-p (eq time :pre)) + then (force-output hsock) + ; do chunking + (setq reply-stream + (make-instance 'chunking-stream + :output-handle reply-stream)) + (setf (request-reply-stream req) + reply-stream)) + + + - (if* (and send-headers compress (eq time :pre)) - then (setq reply-stream - (setf (request-reply-stream req) - (make-instance 'deflate-stream - :target reply-stream - :compress compress - )))) - - - - ; if we did post-headers then there's a string input - ; stream to dump out. - (if* content - then (write-sequence content sock)) - - (if* (and (eq time :post) (prepend-stream-p reply-stream)) - then (force-output reply-stream) - (close reply-stream) ; close prepend stream only - (setq reply-stream - (setf (request-reply-stream req) - (prepend-stream-inner-stream reply-stream)))) - - (if* (and compress (eq time :post)) - then (if* reply-stream - then (force-output reply-stream) - - (close reply-stream) ; close deflate stream - - (setq reply-stream - (setf (request-reply-stream req) (excl::inner-stream reply-stream))) - (and reply-stream (force-output reply-stream)))) - - ;; if we're chunking then shut that off - (if* (and chunked-p (eq time :post)) - then ; unwrap the chunked stream - - (if* reply-stream - then (force-output reply-stream) - (close reply-stream) ; send chunking eof - (setq reply-stream - (setf (request-reply-stream req) (excl::inner-stream reply-stream))) - (and reply-stream (force-output reply-stream)))) - - - - )))) + (if* (and send-headers compress (eq time :pre)) + then (setq reply-stream + (setf (request-reply-stream req) + (make-instance 'deflate-stream + :target reply-stream + :compress compress + )))) + + + ; if we did post-headers then there's a string input + ; stream to dump out. + (if* content + then (write-sequence content sock)) + + (if* (and (eq time :post) (prepend-stream-p reply-stream)) + then (force-output reply-stream) + (close reply-stream) ; close prepend stream only + (setq reply-stream + (setf (request-reply-stream req) + (prepend-stream-inner-stream reply-stream)))) + + (if* (and compress (eq time :post)) + then (if* reply-stream + then (force-output reply-stream) + + (close reply-stream) ; close deflate stream + + (setq reply-stream + (setf (request-reply-stream req) (excl::inner-stream reply-stream))) + (and reply-stream (force-output reply-stream)))) + + ;; if we're chunking then shut that off + (if* (and chunked-p (eq time :post)) + then ; unwrap the chunked stream + + (if* reply-stream + then (force-output reply-stream) + (close reply-stream) ; send chunking eof + (setq reply-stream + (setf (request-reply-stream req) (excl::inner-stream reply-stream))) + (and reply-stream (force-output reply-stream))))))))) diff --git a/test/t-aserve.cl b/test/t-aserve.cl index eb0062de..e56b0631 100644 --- a/test/t-aserve.cl +++ b/test/t-aserve.cl @@ -77,7 +77,8 @@ ) (defparameter *aserve-set-full-debug* nil) ; :all and :notrap are useful -(net.aserve::debug-on *aserve-set-full-debug*) +(when *aserve-set-full-debug* + (apply #'net.aserve::debug-on *aserve-set-full-debug*)) ; to trap errors when they happen uncomment this #+ignore @@ -320,7 +321,8 @@ :listeners 20 ; so keep-alive will be possible ))); let the system pick a port (setq *wserver* wserver) - (net.aserve::debug-on *aserve-set-full-debug*) + (when *aserve-set-full-debug* + (apply #'net.aserve::debug-on *aserve-set-full-debug*)) (logmess (format nil "wserver name is now ~A" (wserver-name *wserver*))) (unpublish :all t) ; flush anything published (setf (asc x-ssl) ssl) @@ -340,7 +342,8 @@ :proxy t :proxy-proxy (asc x-proxy))) (let ((*wserver* (asc proxy-wserver))) - (net.aserve::debug-on *aserve-set-full-debug*) + (when *aserve-set-full-debug* + (apply #'net.aserve::debug-on *aserve-set-full-debug*)) (logmess (format nil "proxy wserver name is ~A" (wserver-name *wserver*)))) (push (asc x-proxy) (asc save-x-proxy)) @@ -2289,8 +2292,21 @@ (doit :protocol :http/1.0)) (ignore-errors (delete-file temp-file-name))))))) - +;; (net.aserve::debug-on :xmit) +;; (net.aserve::debug-off :body) + +;; truncate long bodies +(let ((body-kinds (net.aserve::expand-kinds '(:body)))) + (defmethod net.aserve::logmess1 :around (category level message) + (call-next-method category level + (if (and (member category body-kinds) + (< 100 (length message))) + (concatenate 'string (subseq message 0 100) "...") + message)))) + (if* user::*do-aserve-test* - then (user::test-aserve-n :n user::*do-aserve-test*) + then (when (excl.osi:getenv "ASERVE_LOG_XMIT") + (net.aserve::debug-on :xmit)) + (user::test-aserve-n :n user::*do-aserve-test*) else (format t " (user::test-aserve-n) will run the aserve test~%")) diff --git a/webactions/websession.cl b/webactions/websession.cl index 24a6e41a..a03c59f2 100644 --- a/webactions/websession.cl +++ b/webactions/websession.cl @@ -193,7 +193,7 @@ (sm-websessions sm)) (dolist (websession toreap) - (debug-format :info " flush session ~s~%" (websession-key websession)) + (debug-format :info " flush session ~s" (websession-key websession)) (force-output) (remhash (websession-key websession) (sm-websessions sm)))))