Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

improve logging

<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...
commit ab9efeb4918b8cc3971b48863eabc69885b7dbc5 1 parent 65d85a2
authored February 02, 2012 dklayer committed March 14, 2012
434  client.cl
@@ -363,26 +363,27 @@
363 363
 
364 364
     (unwind-protect
365 365
 	(let (new-location) 
366  
-	  
367  
-	  (loop
368  
-	    (if* (catch 'premature-eof
369  
-		   (read-client-response-headers creq
370  
-						 :throw-on-eof
371  
-						 (and connection
372  
-						      'premature-eof))
373  
-		   ;; if it's a continue, then start the read again
374  
-		   (if* (not (eql 100 (client-request-response-code creq)))
375  
-		      then (return))
  366
+
  367
+          (net.aserve::maybe-accumulate-log (:xmit-client-response-headers "~s")
  368
+            (loop
  369
+              (if* (catch 'premature-eof
  370
+                     (read-client-response-headers creq
  371
+                                                   :throw-on-eof
  372
+                                                   (and connection
  373
+                                                        'premature-eof))
  374
+                     ;; if it's a continue, then start the read again
  375
+                     (if* (not (eql 100 (client-request-response-code creq)))
  376
+                        then (return))
376 377
 		   
377  
-		   nil)
  378
+                     nil)
378 379
 		    
379  
-	       then ; got eof right away.. likely due to bogus
380  
-		    ; saved connection... so try again with
381  
-		    ; no saved connection
382  
-		    (ignore-errors (close connection))
383  
-		    (setf (getf args :connection) nil)
384  
-		    (return-from do-http-request
385  
-		      (apply 'do-http-request uri args))))
  380
+                 then ; got eof right away.. likely due to bogus
  381
+                      ; saved connection... so try again with
  382
+                      ; no saved connection
  383
+                      (ignore-errors (close connection))
  384
+                      (setf (getf args :connection) nil)
  385
+                      (return-from do-http-request
  386
+                        (apply 'do-http-request uri args)))))
386 387
 	  
387 388
 	  (if* (equal "close" (cdr (assoc :connection 
388 389
 					  (client-request-headers creq))))
@@ -452,6 +453,7 @@
452 453
 		     )))
453 454
 	  
454 455
           (let ((body (read-response-body creq :format format)))
  456
+            (net.aserve::debug-format :xmit-client-response-body "~s" body)
455 457
 	    (if* new-location
456 458
 	       then			; must do a redirect to get to the real site
457 459
 		    (client-request-close creq)
@@ -558,11 +560,12 @@
558 560
 			;; bug16130: in case one was left laying around:
559 561
 			:if-exists :supersede))
560 562
 
561  
-	  (loop
562  
-	    (read-client-response-headers creq)
563  
-	    ;; if it's a continue, then start the read again
564  
-	    (if* (not (eql 100 (client-request-response-code creq)))
565  
-	       then (return)))
  563
+          (net.aserve::maybe-accumulate-log (:xmit-client-response-headers "~s")
  564
+           (loop
  565
+             (read-client-response-headers creq)
  566
+             ;; if it's a continue, then start the read again
  567
+             (if* (not (eql 100 (client-request-response-code creq)))
  568
+                then (return))))
566 569
 	  
567 570
 	  (if* (and (member (client-request-response-code creq)
568 571
 			    redirect-codes :test #'eq)
@@ -574,26 +577,27 @@
574 577
 		    (cdr (assoc :location (client-request-headers creq)
575 578
 				:test #'eq))))
576 579
 		
577  
-	  (loop
578  
-	    (if* (and timeout (numberp timeout))
579  
-	       then (let ((res (sys:with-timeout (timeout :timed-out)
580  
-				 (setq end
581  
-				   (client-request-read-sequence buf creq)))))
582  
-		      (if* (eq :timed-out res)
583  
-			 then (error "~a is not responding."
584  
-				     (net.uri:uri-host uri))))
585  
-	       else (setq end (client-request-read-sequence buf creq)))
586  
-	    (if* (zerop end)
587  
-	       then (if* progress-function 
588  
-		       then (funcall progress-function -1 size))
589  
-		    (return)) ;; EOF
590  
-	    (if* progress-at
591  
-	       then (incf bytes-read buffer-size)
592  
-		    (if* (> bytes-read (car progress-at))
593  
-		       then (setq progress-at (cdr progress-at))
594  
-			    (ignore-errors (funcall progress-function bytes-read
595  
-						    size))))
596  
-	    (write-sequence buf s :end end))
  580
+	  (net.aserve::maybe-accumulate-log (:xmit-client-response-body "~s")
  581
+            (loop
  582
+              (if* (and timeout (numberp timeout))
  583
+                 then (let ((res (sys:with-timeout (timeout :timed-out)
  584
+                                   (setq end
  585
+                                         (client-request-read-sequence buf creq)))))
  586
+                        (if* (eq :timed-out res)
  587
+                           then (error "~a is not responding."
  588
+                                       (net.uri:uri-host uri))))
  589
+                 else (setq end (client-request-read-sequence buf creq)))
  590
+              (if* (zerop end)
  591
+                 then (if* progress-function 
  592
+                         then (funcall progress-function -1 size))
  593
+                      (return)) ;; EOF
  594
+              (if* progress-at
  595
+                 then (incf bytes-read buffer-size)
  596
+                      (if* (> bytes-read (car progress-at))
  597
+                         then (setq progress-at (cdr progress-at))
  598
+                              (ignore-errors (funcall progress-function bytes-read
  599
+                                                                        size))))
  600
+              (write-sequence buf s :end end)))
597 601
 	    
598 602
 	  (setq code (client-request-response-code creq))
599 603
 	  
@@ -702,7 +706,6 @@
702 706
 	      (ignore-errors (close connection))
703 707
 	      ; drop into code to do it normally
704 708
 	      )))
705  
-			       
706 709
   (let (host sock port fresh-uri scheme-default-port)
707 710
     ;; start a request 
708 711
   
@@ -832,149 +835,157 @@ or \"foo.com:8000\", not ~s" proxy))
832 835
 			      query :external-format external-format)
833 836
 		     content-type "application/x-www-form-urlencoded"))))
834 837
 		 
835  
-    
836  
-    (net.aserve::format-dif :xmit sock "~a ~a ~a~a"
837  
-			    (string-upcase (string method))
838  
-			    (if* (eq method :connect)
839  
-			       then ;; deliver 'uri' untouched
840  
-				    uri
841  
-			       else (if* proxy
842  
-				       then (net.uri:render-uri uri nil)
843  
-				       else (uri-path-etc uri)))
844  
-			    (string-upcase (string protocol))
845  
-			    crlf)
  838
+
  839
+    (let ((command (format nil "~a ~a ~a"
  840
+                           (string-upcase (string method))
  841
+                           (if* (eq method :connect)
  842
+                              then ;; deliver 'uri' untouched
  843
+                                   uri
  844
+                              else (if* proxy
  845
+                                      then (net.uri:render-uri uri nil)
  846
+                                      else (uri-path-etc uri)))
  847
+                           (string-upcase (string protocol)))))
  848
+      (format sock "~a~a" command crlf)
  849
+      (net.aserve::debug-format :xmit-client-request-command "~s" command))
846 850
     
847 851
     ; write often to trigger error if connection closed
848 852
     (if* use-socket then (force-output sock))
849 853
 
850 854
     ; always send a Host header, required for http/1.1 and a good idea
851 855
     ; for http/1.0
852  
-    (if*  (not (eql scheme-default-port  port))
853  
-       then (net.aserve::format-dif :xmit sock "Host: ~a:~a~a" host port crlf)
854  
-       else (net.aserve::format-dif :xmit  sock "Host: ~a~a" host crlf))
855  
-    
856  
-    
857  
-    ; now the headers
858  
-    (if* (and keep-alive (eq protocol :http/1.0))
859  
-       then ; for http/1.1 keep alive is the default so no need 
860  
-	    ; to express it
861  
-	    (net.aserve::format-dif :xmit
862  
-				    sock "Connection: Keep-Alive~a" crlf)
863  
-     elseif (and (not keep-alive) (eq protocol :http/1.1))
864  
-       then ; request it close for us
865  
-	    (net.aserve::format-dif :xmit
866  
-				    sock "Connection: close~a" crlf))
867  
-
868  
-    
869  
-    (if* accept
870  
-       then (net.aserve::format-dif :xmit
871  
-				    sock "Accept: ~a~a" accept crlf))
872  
-
  856
+    (net.aserve::maybe-accumulate-log (:xmit-client-request-headers "~s")
  857
+      (if*  (not (eql scheme-default-port  port))
  858
+         then (net.aserve::format-dif :xmit-client-request-headers
  859
+                                      sock "Host: ~a:~a~a" host port crlf)
  860
+         else (net.aserve::format-dif :xmit-client-request-headers
  861
+                                      sock "Host: ~a~a" host crlf))
  862
+      
  863
+      
  864
+      ; now the headers
  865
+      (if* (and keep-alive (eq protocol :http/1.0))
  866
+         then ; for http/1.1 keep alive is the default so no need 
  867
+  	    ; to express it
  868
+  	    (net.aserve::format-dif :xmit-client-request-headers
  869
+  				    sock "Connection: Keep-Alive~a" crlf)
  870
+       elseif (and (not keep-alive) (eq protocol :http/1.1))
  871
+         then ; request it close for us
  872
+  	    (net.aserve::format-dif :xmit-client-request-headers
  873
+  				    sock "Connection: close~a" crlf))
873 874
 
874  
-    (if* compress
875  
-       then (net.aserve::format-dif :xmit
876  
-				    sock "Accept-Encoding: gzip~a"  crlf))
877 875
       
878  
-    ; some webservers (including AServe) have trouble with put/post
879  
-    ; requests without a body
880  
-    (if* (and (not content) (member method '(:put :post)))
881  
-       then (setf content ""))
882  
-    ; content can be a nil, a single vector or a list of vectors.
883  
-    ; canonicalize..
884  
-    (if* (and content (atom content)) then (setq content (list content)))
885  
-    
886  
-    (if* content
887  
-       then (let ((computed-length 0))
888  
-	      (dolist (content-piece content)
889  
-		(typecase content-piece
890  
-		  ((array character (*))
891  
-		   (if* (null content-length)
892  
-		      then (incf computed-length 
893  
-				 (native-string-sizeof 
894  
-				  content-piece
895  
-				  :external-format external-format))))
896  
-		 
897  
-		  ((array (unsigned-byte 8) (*)) 
898  
-		   (if* (null content-length)
899  
-		      then (incf computed-length (length content-piece))))
900  
-		  (t (error "Illegal content array: ~s" content-piece))))
901  
-	      
902  
-	      (if* (null content-length)
903  
-		 then (setq content-length computed-length))))
904  
-    
905  
-	    
906  
-    
907  
-    (if* content-length
908  
-       then (net.aserve::format-dif :xmit
909  
-				    sock "Content-Length: ~s~a" content-length crlf))
910  
-  
911  
-	    
912  
-    (if* cookies 
913  
-       then (let ((str (compute-cookie-string uri
914  
-					      cookies)))
915  
-	      (if* str
916  
-		 then (net.aserve::format-dif :xmit
917  
-					      sock "Cookie: ~a~a" str crlf))))
918  
-
919  
-    (if* basic-authorization
920  
-       then (net.aserve::format-dif :xmit sock "Authorization: Basic ~a~a"
921  
-				    (base64-encode
922  
-				     (format nil "~a:~a" 
923  
-					     (car basic-authorization)
924  
-					     (cdr basic-authorization)))
925  
-				    crlf))
926  
-    
927  
-    (if* proxy-basic-authorization
928  
-       then (net.aserve::format-dif :xmit sock "Proxy-Authorization: Basic ~a~a"
929  
-				    (base64-encode
930  
-				     (format nil "~a:~a" 
931  
-					     (car proxy-basic-authorization)
932  
-					     (cdr proxy-basic-authorization)))
933  
-				    crlf))
934  
-    
935  
-    (if* (and digest-authorization
936  
-	      (digest-response digest-authorization))
937  
-       then ; put out digest info
938  
-	    (net.aserve::format-dif 
939  
-	     :xmit sock
940  
-	     "Authorization: Digest username=~s, realm=~s, nonce=~s, uri=~s, qop=~a, nc=~a, cnonce=~s, response=~s~@[, opaque=~s~]~a"
941  
-	     (digest-username digest-authorization)
942  
-	     (digest-realm digest-authorization)
943  
-	     (digest-nonce digest-authorization)
944  
-	     (digest-uri digest-authorization)
945  
-	     (digest-qop digest-authorization)
946  
-	     (digest-nonce-count digest-authorization)
947  
-	     (digest-cnonce digest-authorization)
948  
-	     (digest-response digest-authorization)
949  
-	     (digest-opaque digest-authorization)
950  
-	     crlf))
951  
-	     
952  
-				    
953  
-				    
954  
-
955  
-    (if* user-agent
956  
-       then (if* (stringp user-agent)
957  
-	       thenret
958  
-	     elseif (eq :aserve user-agent)
959  
-	       then (setq user-agent net.aserve::*aserve-version-string*)
960  
-	     elseif (eq :netscape user-agent)
961  
-	       then (setq user-agent "Mozilla/4.7 [en] (WinNT; U)")
962  
-	     elseif (eq :ie user-agent)
963  
-	       then (setq user-agent "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)")
964  
-	       else (error "Illegal user-agent value: ~s" user-agent))
965  
-	    (net.aserve::format-dif :xmit
966  
-				    sock "User-Agent: ~a~a" user-agent crlf))
967  
-
968  
-    (if* content-type
969  
-       then (net.aserve::format-dif :xmit sock "Content-Type: ~a~a"
970  
-				    content-type
971  
-				    crlf))
  876
+      (if* accept
  877
+         then (net.aserve::format-dif :xmit-client-request-headers
  878
+  				    sock "Accept: ~a~a" accept crlf))
  879
+
  880
+
  881
+      (if* compress
  882
+         then (net.aserve::format-dif :xmit-client-request-headers
  883
+  				    sock "Accept-Encoding: gzip~a"  crlf))
  884
+        
  885
+      ; some webservers (including AServe) have trouble with put/post
  886
+      ; requests without a body
  887
+      (if* (and (not content) (member method '(:put :post)))
  888
+         then (setf content ""))
  889
+      ; content can be a nil, a single vector or a list of vectors.
  890
+      ; canonicalize..
  891
+      (if* (and content (atom content)) then (setq content (list content)))
  892
+      
  893
+      (if* content
  894
+         then (let ((computed-length 0))
  895
+  	      (dolist (content-piece content)
  896
+  		(typecase content-piece
  897
+  		  ((array character (*))
  898
+  		   (if* (null content-length)
  899
+  		      then (incf computed-length 
  900
+  				 (native-string-sizeof 
  901
+  				  content-piece
  902
+  				  :external-format external-format))))
  903
+  		 
  904
+  		  ((array (unsigned-byte 8) (*)) 
  905
+  		   (if* (null content-length)
  906
+  		      then (incf computed-length (length content-piece))))
  907
+  		  (t (error "Illegal content array: ~s" content-piece))))
  908
+  	      
  909
+  	      (if* (null content-length)
  910
+  		 then (setq content-length computed-length))))
  911
+      
  912
+  	    
  913
+      
  914
+      (if* content-length
  915
+         then (net.aserve::format-dif :xmit-client-request-headers
  916
+  				    sock "Content-Length: ~s~a" content-length crlf))
972 917
     
973  
-    (if* headers
974  
-       then (dolist (header headers)
975  
-	      (net.aserve::format-dif :xmit sock "~a: ~a~a" 
976  
-				      (car header) (cdr header) crlf)))
977  
-    (if* use-socket then (force-output sock))
  918
+  	    
  919
+      (if* cookies 
  920
+         then (let ((str (compute-cookie-string uri
  921
+  					      cookies)))
  922
+  	      (if* str
  923
+  		 then (net.aserve::format-dif :xmit-client-request-headers
  924
+  					      sock "Cookie: ~a~a" str crlf))))
  925
+
  926
+      (if* basic-authorization
  927
+         then (net.aserve::format-dif :xmit-client-request-headers
  928
+                                      sock "Authorization: Basic ~a~a"
  929
+  				    (base64-encode
  930
+  				     (format nil "~a:~a" 
  931
+  					     (car basic-authorization)
  932
+  					     (cdr basic-authorization)))
  933
+  				    crlf))
  934
+      
  935
+      (if* proxy-basic-authorization
  936
+         then (net.aserve::format-dif :xmit-client-request-headers
  937
+                                      sock "Proxy-Authorization: Basic ~a~a"
  938
+  				    (base64-encode
  939
+  				     (format nil "~a:~a" 
  940
+  					     (car proxy-basic-authorization)
  941
+  					     (cdr proxy-basic-authorization)))
  942
+  				    crlf))
  943
+      
  944
+      (if* (and digest-authorization
  945
+  	      (digest-response digest-authorization))
  946
+         then ; put out digest info
  947
+  	    (net.aserve::format-dif 
  948
+  	     :xmit-client-request-headers sock
  949
+  	     "Authorization: Digest username=~s, realm=~s, nonce=~s, uri=~s, qop=~a, nc=~a, cnonce=~s, response=~s~@[, opaque=~s~]~a"
  950
+  	     (digest-username digest-authorization)
  951
+  	     (digest-realm digest-authorization)
  952
+  	     (digest-nonce digest-authorization)
  953
+  	     (digest-uri digest-authorization)
  954
+  	     (digest-qop digest-authorization)
  955
+  	     (digest-nonce-count digest-authorization)
  956
+  	     (digest-cnonce digest-authorization)
  957
+  	     (digest-response digest-authorization)
  958
+  	     (digest-opaque digest-authorization)
  959
+  	     crlf))
  960
+  	     
  961
+  				    
  962
+  				    
  963
+
  964
+      (if* user-agent
  965
+         then (if* (stringp user-agent)
  966
+  	       thenret
  967
+  	     elseif (eq :aserve user-agent)
  968
+  	       then (setq user-agent net.aserve::*aserve-version-string*)
  969
+  	     elseif (eq :netscape user-agent)
  970
+  	       then (setq user-agent "Mozilla/4.7 [en] (WinNT; U)")
  971
+  	     elseif (eq :ie user-agent)
  972
+  	       then (setq user-agent "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)")
  973
+  	       else (error "Illegal user-agent value: ~s" user-agent))
  974
+  	    (net.aserve::format-dif :xmit-client-request-headers
  975
+  				    sock "User-Agent: ~a~a" user-agent crlf))
  976
+
  977
+      (if* content-type
  978
+         then (net.aserve::format-dif :xmit-client-request-headers
  979
+                                      sock "Content-Type: ~a~a"
  980
+  				    content-type
  981
+  				    crlf))
  982
+      
  983
+      (if* headers
  984
+         then (dolist (header headers)
  985
+  	      (net.aserve::format-dif :xmit-client-request-headers
  986
+                                       sock "~a: ~a~a" 
  987
+  				      (car header) (cdr header) crlf)))
  988
+      (if* use-socket then (force-output sock)))
978 989
     
979 990
 
980 991
     (write-string crlf sock)  ; final crlf
@@ -986,11 +997,14 @@ or \"foo.com:8000\", not ~s" proxy))
986 997
     (if* content
987 998
        then ; content can be a vector a list of vectors
988 999
 	    (dolist (cont content)
989  
-	      (net.aserve::if-debug-action 
990  
-	       :xmit
991  
-	       (format net.aserve::*debug-stream*
992  
-		       "client sending content of ~d characters/bytes"
993  
-		       (length cont)))
  1000
+              (net.aserve::debug-format
  1001
+               :info "client sending content of ~d characters/bytes"
  1002
+               (length cont))
  1003
+              (net.aserve::debug-format
  1004
+               :xmit-client-request-body
  1005
+               "~s" (if (stringp cont)
  1006
+                        cont
  1007
+                        (octets-to-string cont :external-format :octets)))
994 1008
 	      (write-sequence cont sock)))
995 1009
     
996 1010
     
@@ -1042,6 +1056,8 @@ or \"foo.com:8000\", not ~s" proxy))
1042 1056
 			    (throw throw-on-eof t))
1043 1057
 		    
1044 1058
 		    (error "premature eof from server"))
  1059
+          (net.aserve::debug-format :xmit-client-response-headers "~a~a"
  1060
+                                    (subseq buff 0 len) crlf)
1045 1061
 	  (macrolet ((fail ()
1046 1062
 		       `(let ((i 0))
1047 1063
 			  (error "illegal response from web server: ~s"
@@ -1185,38 +1201,36 @@ or \"foo.com:8000\", not ~s" proxy))
1185 1201
 										bytes-left)))))
1186 1202
 		      (if* (eq ans start)
1187 1203
 			 then 0  ; eof
1188  
-			 else (net.aserve::if-debug-action :xmit
1189  
-							   (write-sequence 
1190  
-							    buffer 
1191  
-							    net.aserve::*debug-stream*
1192  
-							    :start start
1193  
-							    :end
1194  
-							    ans))
  1204
+			 else (net.aserve::debug-format
  1205
+                               :xmit-client-response-body "~s"
  1206
+                               (octets-to-string buffer :start start :end ans
  1207
+                                                 :external-format :octets))
1195 1208
 			      (setf (client-request-bytes-left creq)
1196 1209
 				(- bytes-left (- ans start)))
1197 1210
 			      ans)))
1198 1211
      elseif (or (eq bytes-left :chunked)
1199 1212
 		(eq bytes-left :unknown))
1200  
-       then (handler-case (do ((i start (1+ i))
1201  
-			       (stringp (stringp buffer))
1202  
-			       (debug-on (member :xmit 
1203  
-						 net.aserve::*debug-current*
1204  
-						 :test #'eq)))
1205  
-			      ((>= i end) (setq last end))
1206  
-			    (setq last i)
1207  
-			    (let ((ch (if* stringp
1208  
-					 then (read-char socket nil nil)
1209  
-					 else (read-byte socket nil nil))))
1210  
-			      (if* (null ch)
1211  
-				 then (setf (client-request-bytes-left creq) :eof)
1212  
-				      (return)
1213  
-				 else (if* debug-on
1214  
-					 then (write-char
1215  
-					       (if* (characterp ch) 
1216  
-						  then ch
1217  
-						  else (code-char ch))
1218  
-					       net.aserve::*debug-stream*))
1219  
-				      (setf (aref buffer i) ch))))
  1213
+       then (handler-case
  1214
+                (do ((i start (1+ i))
  1215
+                     (stringp (stringp buffer))
  1216
+                     (debug-on (member :xmit-client-response-body
  1217
+                                       net.aserve::*debug-current*
  1218
+                                       :test #'eq)))
  1219
+                    ((>= i end) (setq last end))
  1220
+                  (setq last i)
  1221
+                  (let ((ch (if* stringp
  1222
+                               then (read-char socket nil nil)
  1223
+                               else (read-byte socket nil nil))))
  1224
+                    (if* (null ch)
  1225
+                       then (setf (client-request-bytes-left creq) :eof)
  1226
+                            (return)
  1227
+                       else (if* debug-on
  1228
+                               then (net.aserve::debug-format
  1229
+                                     :xmit-client-response-body "~a"
  1230
+                                                                (if* (characterp ch) 
  1231
+                                                                   then ch
  1232
+                                                                   else (code-char ch))))
  1233
+                            (setf (aref buffer i) ch))))
1220 1234
 	      (excl::socket-chunking-end-of-file
1221 1235
 		  (cond)
1222 1236
 		(declare (ignore cond))
5  headers.cl
@@ -703,7 +703,10 @@
703 703
   (let* ((buff (get-sresource *header-block-sresource*))
704 704
 	 (end (read-headers-into-buffer sock buff)))
705 705
     (if* end
706  
-       then (prog1 (parse-and-listify-header-block buff end)
  706
+       then (debug-format :xmit-client-response-headers "~a"
  707
+                          (octets-to-string buff :end end
  708
+                                            :external-format :octets))
  709
+            (prog1 (parse-and-listify-header-block buff end)
707 710
 	      (free-sresource *header-block-sresource* buff))
708 711
        else (free-sresource *header-block-sresource* buff)
709 712
 	    (error "Incomplete headers sent by server"))))
139  log.cl
@@ -35,6 +35,29 @@
35 35
 
36 36
 (in-package :net.aserve)
37 37
 
  38
+(defun log1 (category level message &key (logger *logger*))
  39
+  (log1* logger category level message))
  40
+
  41
+(defgeneric log1* (logger category level message)
  42
+  (:documentation "This the new, extensible logger interface to which
  43
+all others defer. By default, category :access is handled by
  44
+log-request* while the rest goes to logmess-stream. Note message is
  45
+not necessarily a string: for instance it is a request object
  46
+for :access which allows for more flexibility in presentation.")
  47
+  (:method (logger category level message)
  48
+    (declare (ignore logger))
  49
+    (logmess-stream category level message *debug-stream*))
  50
+  (:method (logger (category (eql :xmit-server-response-headers)) level message)
  51
+    (declare (ignore logger))
  52
+    ;; time is :pre or :post depending on whether the headers are
  53
+    ;; generated before or after the body
  54
+    (destructuring-bind (time string) message
  55
+      (logmess-stream category level (format nil "~a ~s" time string)
  56
+                      *debug-stream*)))
  57
+  (:method (logger (category (eql :access)) level (request http-request))
  58
+    (declare (ignore logger level))
  59
+    (log-request* request)))
  60
+
38 61
 (defvar *enable-logging* t) ; to turn on/off the standard logging method
39 62
 
40 63
 (defvar *save-commands* nil) ; if true then a stream to which to write commands
@@ -43,21 +66,27 @@
43 66
   (log-for-wserver *wserver* message format))
44 67
 
45 68
 (defmethod log-for-wserver ((wserver wserver) message format)
46  
-  ;; send log message to the default vhost's error stream 
47  
-  (logmess-stream message (vhost-error-stream (wserver-default-vhost wserver)) format))
  69
+  ;; send log message to the default vhost's error stream
  70
+  (let ((*debug-stream* (vhost-error-stream (wserver-default-vhost wserver)))
  71
+        (*debug-format* format))
  72
+    (log1 :aserve :info message)))
  73
+
  74
+(defvar *log-time-zone* 0)
48 75
 
49  
-(defmethod logmess-stream (message stream &optional (format :long))
  76
+(defmethod logmess-stream (category level message stream
  77
+                           &optional (format *debug-format*))
50 78
   ;; send the log message to the given stream which should be a
51 79
   ;; stream object and not a stream indicator (like t)
52 80
   ;; If the stream has a lock use that.
  81
+  (declare (ignore level))
53 82
   (multiple-value-bind (csec cmin chour cday cmonth cyear)
54  
-      (decode-universal-time (get-universal-time))
  83
+      (decode-universal-time (get-universal-time) *log-time-zone*)
55 84
     (let* ((*print-pretty* nil)
56 85
 	   (str (ecase format
57 86
                   (:long
58 87
                    (format
59  
-                    nil "~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%"
60  
-                    (mp:process-name sys:*current-process*)
  88
+                    nil "[~a] ~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%"
  89
+                    category (mp:process-name sys:*current-process*)
61 90
                     cmonth cday (mod cyear 100) chour cmin csec
62 91
                     message))
63 92
                   (:brief
@@ -72,51 +101,11 @@
72 101
 	 else (write-sequence str stream)
73 102
 	      (finish-output stream)))))
74 103
 
75  
-
76 104
 (defmethod log-request ((req http-request))
77 105
   ;; after the request has been processed, write out log line
78 106
   (if* *enable-logging*
79  
-     then (let* ((ipaddr (socket:remote-host (request-socket req)))
80  
-		 (time   (request-reply-date req))
81  
-		 (code   (let ((obj (request-reply-code req)))
82  
-			   (if* obj
83  
-			      then (response-number obj)
84  
-			      else 999)))
85  
-		 (length  (or (request-reply-content-length req)
86  
-			      #+(and allegro (version>= 6))
87  
-			      (excl::socket-bytes-written 
88  
-			       (request-socket req))))
89  
-	
90  
-		 (stream (vhost-log-stream (request-vhost req)))
91  
-		
92  
-		 (lock (and (streamp stream)
93  
-			    (getf (excl::stream-property-list stream) 
94  
-				  :lock))))
95  
-
96  
-	    (macrolet ((do-log ()
97  
-			 '(progn (format stream
98  
-				  "~A~A~a - - [~a] ~s ~s ~s~%"
99  
-				  (if* *log-wserver-name* 
100  
-				     then (wserver-name *wserver*) 
101  
-				     else "")
102  
-				  (if* *log-wserver-name* 
103  
-				     then " " 
104  
-				     else "")
105  
-				  (socket:ipaddr-to-dotted ipaddr)
106  
-				  (maybe-universal-time-to-date time)
107  
-				  (request-raw-request req)
108  
-				  code
109  
-				  (or length -1))
110  
-			   (force-output stream))))
111  
-			 
112  
-	      (if* lock
113  
-		 then (mp:with-process-lock (lock)
114  
-			; in case stream switched out while we weren't busy
115  
-			; get the stream again
116  
-			(setq stream (vhost-log-stream (request-vhost req)))
117  
-			(do-log))
118  
-		 else (do-log)))))
119  
-  
  107
+     then ;; By default this ends up calling log-request*.
  108
+          (log1 :access :info req))
120 109
   (if* *save-commands*
121 110
      then (multiple-value-bind (ok whole uri-string)
122 111
 	      (match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req))
@@ -133,15 +122,49 @@
133 122
 		    (let ((bod (request-request-body req)))
134 123
 		      (and (not (equal "" bod)) bod))
135 124
 		    (multiple-value-list (get-basic-authorization req))
136  
-		    (header-slot-value req :content-type)
137  
-		    ))
138  
-	  (force-output *save-commands*))
139  
-		  
140  
-	  
141  
-  )
  125
+		    (header-slot-value req :content-type)))
  126
+	  (force-output *save-commands*)))
142 127
 
143  
-	    	
144  
-    
  128
+(defun log-request* (req)
  129
+  (let* ((entry (format-access-log-entry req))
  130
+         (stream (vhost-log-stream (request-vhost req)))
  131
+         (lock (and (streamp stream)
  132
+                    (getf (excl::stream-property-list stream) 
  133
+                          :lock))))
  134
+    (macrolet ((do-log ()
  135
+                 '(progn (format stream "~a~%" entry)
  136
+                   (force-output stream))))
  137
+      (if* lock
  138
+         then (mp:with-process-lock (lock)
  139
+                ; in case stream switched out while we weren't busy
  140
+                ; get the stream again
  141
+                (setq stream (vhost-log-stream (request-vhost req)))
  142
+                (do-log))
  143
+         else (do-log)))))
  144
+
  145
+(defun format-access-log-entry (req)
  146
+  (let* ((ipaddr (socket:remote-host (request-socket req)))
  147
+         (time   (request-reply-date req))
  148
+         (code   (let ((obj (request-reply-code req)))
  149
+                   (if* obj
  150
+                      then (response-number obj)
  151
+                      else 999)))
  152
+         (length (or (request-reply-content-length req)
  153
+                     #+(and allegro (version>= 6))
  154
+                     (excl::socket-bytes-written 
  155
+                      (request-socket req)))))
  156
+    (format nil "~A~A~a - - [~a] ~s ~s ~s"
  157
+            (if* *log-wserver-name* 
  158
+               then (wserver-name *wserver*) 
  159
+               else "")
  160
+            (if* *log-wserver-name* 
  161
+               then " " 
  162
+               else "")
  163
+            (socket:ipaddr-to-dotted ipaddr)
  164
+            (maybe-universal-time-to-date time)
  165
+            (request-raw-request req)
  166
+            code
  167
+            (or length -1))))
145 168
     
146 169
 (defun log-proxy (uri level action extra)
147 170
   ;; log information from the proxy module
@@ -158,7 +181,3 @@
158 181
 	      else (net.uri:render-uri uri nil))
159 182
 	   extra)
160 183
    :brief))
161  
-
162  
-    
163  
-  
164  
-
413  main.cl
@@ -55,105 +55,260 @@
55 55
 	    (cadr *aserve-version*)
56 56
 	    (caddr *aserve-version*)))
57 57
 	    
58  
-;;;;;;;  debug support 
  58
+;;;;;;;  debug support
  59
+
  60
+;; An alist of kind and the superkinds it belongs to. 
  61
+(defparameter *debug-kinds* ())
59 62
 
60  
-(defparameter *debug-all* nil)	; all of the debugging switches
61  
-(defparameter *debug-log* nil)  ; all debugging switches that write info
62  
-				; to the *debug-stream*
63 63
 (defparameter *debug-current*  nil)	; current switches set
64 64
 
65 65
 (defparameter *debug-stream* *initial-terminal-io*)
66 66
 
  67
+(defparameter *debug-format* :long)
  68
+
67 69
 ; set to true to automatically close sockets about to be gc'ed
68 70
 ; open sockets should never be subject to gc unless there's a bug
69 71
 ; in the code leading to leaks.
70  
-(defvar *watch-for-open-sockets* t) 
  72
+(defvar *watch-for-open-sockets* t)
71 73
 
72  
-(defmacro define-debug-kind (name class what)
73  
-  `(progn (ecase ,class
74  
-	    (:all (pushnew ,name *debug-all*))
75  
-	    (:log (pushnew ,name *debug-log*)
76  
-		  (pushnew ,name *debug-all*)))
77  
-	  (setf (get ,name 'debug-description) ,what)))
  74
+(defun find-kind-entry (kind)
  75
+  (find kind *debug-kinds* :key #'car))
78 76
 
79  
-(define-debug-kind :notrap :all 
80  
-  "If set than errors in handlers cause a break loop to be entered")
  77
+(defun add-new-kind (kind superkinds documentation)
  78
+  (if* (find-kind-entry kind)
  79
+     then (error "Debug kind ~s already defined." kind))
  80
+  (dolist (superkind superkinds)
  81
+    (if* (null (find-kind-entry superkind))
  82
+       then (error "Can't find superkind ~s for ~s." superkind kind)))
  83
+  (push (cons kind superkinds) *debug-kinds*)
  84
+  (setf (get kind 'debug-description) documentation))
81 85
 
82  
-(define-debug-kind :xmit   :log
83  
-  "If set then most of the traffic between clients and servers is also sent to the debug stream")
  86
+(defmacro define-debug-kind (kind superkinds documentation)
  87
+  `(add-new-kind ,kind ',superkinds ,documentation))
84 88
 
85  
-(define-debug-kind :info   :log
86  
-  "General information")
  89
+(define-debug-kind :all ()
  90
+  "The mother of all debug features.")
87 91
 
88  
-(define-debug-kind :zoom-on-error :all
89  
-  "If set then print a zoom to the vhost-error-stream when an error occurs in a handler")
90  
-    
  92
+(define-debug-kind :notrap (:all)
  93
+  "If set than errors in handlers cause a break loop to be entered.")
  94
+
  95
+(define-debug-kind :zoom-on-error (:all)
  96
+  "If set then print a zoom to the vhost-error-stream when an error occurs in a handler.")
  97
+
  98
+(define-debug-kind :log (:all)
  99
+  "Category of features that write some kind of log.")
  100
+
  101
+(define-debug-kind :xmit (:log)
  102
+  "Category of features that log the traffic between clients, servers.")
  103
+
  104
+(define-debug-kind :info (:log)
  105
+  "General information.")
  106
+
  107
+(define-debug-kind :client (:all)
  108
+  "Category of features that log client communication.")
  109
+
  110
+(define-debug-kind :server (:all)
  111
+  "Category of features that log server communication.")
  112
+
  113
+(define-debug-kind :proxy (:all)
  114
+  "Category of features that log proxy communication.")
  115
+
  116
+(define-debug-kind :request (:all)
  117
+  "Category of features that log requests.")
  118
+
  119
+(define-debug-kind :response (:all)
  120
+  "Category of features that log responses.")
  121
+
  122
+(define-debug-kind :command (:all)
  123
+  "Category of features that log http request commands.")
  124
+
  125
+(define-debug-kind :headers (:all)
  126
+  "Category of features that log request/response headers.")
  127
+
  128
+(define-debug-kind :body (:all)
  129
+  "Category of features that log request/response bodies.")
  130
+
  131
+
  132
+(define-debug-kind :xmit-client-request-command
  133
+    (:xmit :client :request :command)
  134
+  "If set then print the client request commands.")
  135
+
  136
+(define-debug-kind :xmit-client-request-headers
  137
+    (:xmit :client :request :headers)
  138
+  "If set then print the client request headers.")
  139
+
  140
+(define-debug-kind :xmit-client-request-body
  141
+    (:xmit :client :request :body)
  142
+  "If set then print the client request bodies.")
  143
+
  144
+(define-debug-kind :xmit-client-response-headers
  145
+    (:xmit :client :response :headers)
  146
+  "If set then print the client response headers.")
  147
+
  148
+(define-debug-kind :xmit-client-response-body
  149
+    (:xmit :client :response :body)
  150
+  "If set then print the client response bodies.")
  151
+
  152
+
  153
+(define-debug-kind :xmit-server-request-command
  154
+    (:xmit :server :request :command)
  155
+  "If set then print the server request commands.")
  156
+
  157
+(define-debug-kind :xmit-server-request-headers
  158
+    (:xmit :server :request :headers)
  159
+  "If set then print the server request headers.")
  160
+
  161
+(define-debug-kind :xmit-server-request-body
  162
+    (:xmit :server :request :body)
  163
+  "If set then print the server request bodies.")
  164
+
  165
+(define-debug-kind :xmit-server-response-headers
  166
+    (:xmit :server :response :headers)
  167
+  "If set then print the server response headers.")
  168
+
  169
+(define-debug-kind :xmit-server-response-body
  170
+    (:xmit :server :response :body)
  171
+  "If set then print the server response bodies.")
  172
+
  173
+;; These are parallell to the client and server kinds, from the point
  174
+;; of view of the proxy. That is, :xmit-proxy-client-request-command
  175
+;; is what the proxy sends on as a client to the real server.
  176
+
  177
+(define-debug-kind :xmit-proxy-client-request-command
  178
+    (:xmit :proxy :client :request :command)
  179
+  "If set then print the proxy request command sent to the real server.")
  180
+
  181
+(define-debug-kind :xmit-proxy-client-request-headers
  182
+    (:xmit :proxy :client :request :headers)
  183
+  "If set then print the proxy request headers sent to the real server.")
  184
+
  185
+(define-debug-kind :xmit-proxy-client-request-body
  186
+    (:xmit :proxy :client :request :body)
  187
+  "If set then print the proxy request bodies sent to the real server.")
  188
+
  189
+(define-debug-kind :xmit-proxy-client-response-headers
  190
+    (:xmit :proxy :client :response :headers)
  191
+  "If set then print the proxy response headers sent by the real server.")
  192
+
  193
+(define-debug-kind :xmit-proxy-client-response-body
  194
+    (:xmit :proxy :client :response :body)
  195
+  "If set then print the proxy response bodies sent by the real server.")
  196
+
  197
+;; What the proxy as a server sends to the real client. Note there are
  198
+;; no :xmit-proxy-server-request-* kinds, because at the time of
  199
+;; reading the request it's not yet known whether it's the going to be
  200
+;; proxied so these show up as :xmit-server-request-*.
  201
+
  202
+(define-debug-kind :xmit-proxy-server-response-headers
  203
+    (:xmit :proxy :server :response :headers)
  204
+  "If set then print the proxy response headers sent to the client.")
  205
+
  206
+(define-debug-kind :xmit-proxy-server-response-body
  207
+    (:xmit :proxy :server :response :body)
  208
+  "If set then print the proxy response bodies sent by the client.")
  209
+
  210
+(defun expand-kinds (kinds)
  211
+  (dolist (kind kinds)
  212
+    (if* (null (find-kind-entry kind))
  213
+       then (error "Can't find kind ~s." kind)))
  214
+  (let ((kinds kinds))
  215
+    (loop for entry in (reverse *debug-kinds*)
  216
+          do (destructuring-bind (kind &rest superkinds) entry
  217
+               (when (intersection superkinds kinds)
  218
+                 (pushnew kind kinds))))
  219
+    kinds))
91 220
 
92 221
 (defun debug-on (&rest args)
93 222
   ;; add the given debug kinds to the log list
94 223
   (if* (null args)
95 224
      then (note-debug-set)
96  
-     else (dolist (arg args)
97  
-	    (case arg
98  
-	      (:all (setq *debug-current* *debug-all*))
99  
-	      (:log (setq *debug-current*
100  
-		      (union *debug-current* *debug-log*)))
101  
-	      (t (pushnew arg *debug-current*))))))
  225
+     else (setq *debug-current*
  226
+                (union *debug-current* (expand-kinds args)))))
102 227
 
103 228
 (defun debug-off (&rest args)
104 229
   ;; turn off the debugging
105 230
   (if* (null args)
106 231
      then (note-debug-set)
107  
-     else (dolist (arg args)
108  
-	    (case arg
109  
-	      (:all (setq *debug-current* nil))
110  
-	      (:log (setq *debug-current*
111  
-		      (set-difference *debug-current* *debug-log*)))
112  
-	      (t (setq *debug-current* (remove arg *debug-current*)))))))
  232
+     else (setq *debug-current*
  233
+                (set-difference *debug-current* (expand-kinds args)))))
113 234
 
114 235
 (defun note-debug-set ()
115 236
   ;; describe what debugging switches exist and if they are on
116 237
   ;; and off
117  
-  (dolist (kind *debug-all*)
118  
-    (format t "~7s ~4a  ~a~%" 
119  
-	    kind
120  
-	    (if* (member kind *debug-current*)
121  
-	       then "on"
122  
-	       else "off")
123  
-	    (get kind 'debug-description))))
  238
+  (dolist (entry (reverse *debug-kinds*))
  239
+    (destructuring-bind (kind &rest superkinds) entry
  240
+      (format t "~40s ~4a~%    ~a~%~a"
  241
+              kind
  242
+              (if* (member kind *debug-current*)
  243
+                 then "on"
  244
+                 else "off")
  245
+              (get kind 'debug-description)
  246
+              (if* superkinds
  247
+                 then (format nil "    (parent categories: ~{~s~^, ~})~%"
  248
+                                  superkinds)
  249
+                 else "")))))
  250
+
  251
+
  252
+(defun format-debug-message (kind stream format args)
  253
+  (declare (ignore kind))
  254
+  (apply #'format stream format args))
124 255
 
125  
-	    
126  
-
127  
-(defmacro debug-format (kind &rest args)
128  
-  ;; do the format to *debug-stream* if the kind of this info
129  
-  ;; is matched by the value of *debug-current*
  256
+(defmacro if-debug-action (kind &body body)
  257
+  ;; only do if the debug value is high enough
130 258
   `(if* (member ,kind *debug-current* :test #'eq)
131  
-      then (write-sequence 
132  
-	    (concatenate 'string
133  
-	      (format nil "d> (~a): " (mp:process-name sys:*current-process*))
134  
-	      (format nil ,@args))
135  
-	    *debug-stream*)))
  259
+      then ,@body))
  260
+
  261
+;; An alist that maps debug kinds to streams. See
  262
+;; maybe-accumulate-log.
  263
+(defvar *accumulating-kinds-and-streams* ())
136 264
 
  265
+(defun accumulator-stream-for-kind (kind)
  266
+  (cdr (assoc kind *accumulating-kinds-and-streams*)))
137 267
 
138  
-(defmacro format-dif (debug-key &rest args)
  268
+(defmacro debug-format (kind format &rest args)
  269
+  ;; do the format to *debug-stream* if the kind of this info
  270
+  ;; is matched by the value of *debug-current*
  271
+  `(if-debug-action ,kind
  272
+     (let ((accumulator-stream (accumulator-stream-for-kind ,kind)))
  273
+       (if accumulator-stream
  274
+           (format accumulator-stream ,format ,@args)
  275
+           (log1 ,kind :info (format-debug-message ,kind nil ,format
  276
+                                                   (list ,@args)))))))
  277
+
  278
+(defmacro maybe-accumulate-log ((debug-action sink) &body body)
  279
+  (let ((debug-output-stream (gensym "debug-output-stream"))
  280
+        (tag (gensym "tag"))
  281
+        (%sink (gensym "sink")))
  282
+    `(flet ((body ()
  283
+              ,@body))
  284
+       (let ((,%sink ,sink))
  285
+         (catch ',tag
  286
+           (or (if-debug-action ,debug-action
  287
+                 (with-output-to-buffer (,debug-output-stream)
  288
+                   (unwind-protect
  289
+                        (let ((*accumulating-kinds-and-streams*
  290
+                                (or (if-debug-action ,debug-action
  291
+                                      (cons (cons ,debug-action
  292
+                                                  ,debug-output-stream)
  293
+                                            *accumulating-kinds-and-streams*))
  294
+                                    *accumulating-kinds-and-streams*)))
  295
+                          (throw ',tag (body)))
  296
+                     (let ((string (multiple-value-bind (buffer length)
  297
+                                       (get-output-stream-buffer
  298
+                                        ,debug-output-stream)
  299
+                                     (octets-to-string
  300
+                                      buffer :end length
  301
+                                      :external-format :octets))))
  302
+                       (if (functionp ,%sink)
  303
+                           (funcall ,%sink string)
  304
+                           (debug-format ,debug-action ,%sink string))))))
  305
+               (body)))))))
  306
+
  307
+(defmacro format-dif (kind &rest args)
139 308
   ;; do the format and also do the same format to the 
140 309
   ;; debug stream if the given debug keyword is set
141  
-  ;; do the format and then send to *initial-terminal-io*
142 310
   `(progn (format ,@args)
143  
-	  (if* (member ,debug-key *debug-current* :test #'eq)
144  
-	     then ; do extra consing to ensure that it all be written out 
145  
-		  ; at once
146  
-		  (write-sequence
147  
-		   (concatenate 'string 
148  
-		     (format nil "x>(~a): " 
149  
-			     (mp:process-name sys:*current-process*))
150  
-		     (format nil ,@(cdr args)))
151  
-		   *debug-stream*))))
152  
-
153  
-(defmacro if-debug-action (kind &body body)
154  
-  ;; only do if the debug value is high enough
155  
-  `(progn (if* (member ,kind *debug-current* :test #'eq)
156  
-	     then ,@body)))
  311
+          (debug-format ,kind ,@(cdr args))))
157 312
 
158 313
 (defun check-for-open-socket-before-gc (socket)
159 314
   (if* (open-stream-p socket)
@@ -283,6 +438,13 @@
283 438
     :initform nil
284 439
     :accessor wserver-filters)
285 440
    
  441
+   (logger
  442
+    ;; on opaque object that's passed to log1* on which it can
  443
+    ;; dispatch
  444
+    :initarg :logger
  445
+    :initform t
  446
+    :accessor wserver-logger)
  447
+
286 448
    (log-function
287 449
     ;; function to call after the request is done to 
288 450
     ;; do the logging
@@ -530,6 +692,16 @@
530 692
 External-format `~s' passed to make-http-client-request filters line endings.
531 693
 Problems with protocol may occur." (ef-name ef)))))
532 694
 
  695
+(defun check-external-format (external-format)
  696
+  (declare (ignorable external-format))
  697
+  #+(and allegro (version>= 6 0 pre-final 1))
  698
+  (if* (and (streamp *html-stream*)
  699
+            (not (eq external-format
  700
+                     (stream-external-format *html-stream*))))
  701
+     then (warn-if-crlf external-format)
  702
+          (setf (stream-external-format *html-stream*)
  703
+                external-format)))
  704
+
533 705
 (defmacro with-http-body ((req ent
534 706
 			   &key headers 
535 707
 				(external-format 
@@ -540,7 +712,7 @@ Problems with protocol may occur." (ef-name ef)))))
540 712
 	(g-ent (gensym))
541 713
 	(g-headers (gensym))
542 714
 	(g-external-format (gensym))
543  
-	)
  715
+	(g-old-request-reply-stream (gensym)))
544 716
     `(let ((,g-req ,req)
545 717
 	   (,g-ent ,ent)
546 718
 	   (,g-headers ,headers)
@@ -556,16 +728,26 @@ Problems with protocol may occur." (ef-name ef)))))
556 728
 	  then (bulk-set-reply-headers ,g-req ,g-headers))
557 729
        (send-response-headers ,g-req ,g-ent :pre)
558 730
        (if* (not (member :omit-body (request-reply-strategy ,g-req) 
559  
-			 :test #'eq))
560  
-	  then (let ((*html-stream* (request-reply-stream ,g-req)))
561  
-		 #+(and allegro (version>= 6 0 pre-final 1))
562  
-		 (if* (and (streamp *html-stream*)
563  
-			   (not (eq ,g-external-format
564  
-				    (stream-external-format *html-stream*))))
565  
-		    then (warn-if-crlf ,g-external-format)
566  
-			 (setf (stream-external-format *html-stream*)
567  
-			   ,g-external-format))
568  
-		 (progn ,@body)))
  731
+                         :test #'eq))
  732
+          then (if* (member :xmit-server-response-body *debug-current*)
  733
+                  then (maybe-accumulate-log (:xmit-server-response-body "~s")
  734
+                         (let ((,g-old-request-reply-stream
  735
+                                 (request-reply-stream ,g-req)))
  736
+                           (unwind-protect
  737
+                                (let ((*html-stream*
  738
+                                        (make-broadcast-stream
  739
+                                         (accumulator-stream-for-kind
  740
+                                          :xmit-server-response-body)
  741
+                                         (request-reply-stream ,g-req))))
  742
+                                  (check-external-format ,g-external-format)
  743
+                                  (setf (request-reply-stream ,g-req)
  744
+                                        *html-stream*)
  745
+                                  ,@body)
  746
+                             (setf (request-reply-stream ,g-req)
  747
+                                   ,g-old-request-reply-stream))))
  748
+                  else (let ((*html-stream* (request-reply-stream ,g-req)))
  749
+                         (check-external-format ,g-external-format)
  750
+                         ,@body)))
569 751
        
570 752
        (if* (member :keep-alive (request-reply-strategy ,g-req) :test #'eq)
571 753
 	  then ; force the body to be read so we can continue
@@ -1207,6 +1389,21 @@ by keyword symbols and not by strings"
1207 1389
 	      nil)))
1208 1390
       (close main-socket))))
1209 1391
 
  1392
+;; Bound to wserver-logger if that's set when logging for a particular
  1393
+;; wserver. Log messages coming from the client use the global value.
  1394
+(defvar *logger* nil)
  1395
+
  1396
+(defun initial-bindings ()
  1397
+  #+(version>= 9 0 :alpha 44)
  1398
+  `((*wserver*  . ',*wserver*)
  1399
+    (*logger* . ',(or (wserver-logger *wserver*)
  1400
+                      *logger*))
  1401
+    ,@excl:*required-top-level-bindings*)
  1402
+  #-(version>= 9 0 :alpha 44)
  1403
+  `((*wserver*  . ',*wserver*)
  1404
+    (*logger* . ',(or (wserver-logger *wserver*)
  1405
+                      *logger*))
  1406
+    ,@excl:*cl-default-special-bindings*))
1210 1407
 	
1211 1408
 (defun start-lisp-thread-server (listeners)
1212 1409
   ;; start a server that consists of a set of lisp threads for
@@ -1226,13 +1423,7 @@ by keyword symbols and not by strings"
1226 1423
 			       then (wserver-name *wserver*) 
1227 1424
 			       else "aserve")
1228 1425
 			    (atomic-incf *thread-index*))
1229  
-	      :initial-bindings
1230  
-	      #+(version>= 9 0 :alpha 44)
1231  
-	      `((*wserver*  . ',*wserver*)
1232  
-		,@excl:*required-top-level-bindings*)
1233  
-	      #-(version>= 9 0 :alpha 44)
1234  
-	      `((*wserver*  . ',*wserver*)
1235  
-		,@excl:*cl-default-special-bindings*))
  1426
+	      :initial-bindings (initial-bindings))
1236 1427
       #'http-accept-thread)))
1237 1428
 
1238 1429
 ;; 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"
1246 1437
 			  then (wserver-name *wserver*) 
1247 1438
 			  else "aserve")))
1248 1439
 	 (proc (mp:make-process :name name
1249  
-				:initial-bindings
1250  
-				#+(version>= 9 0 :alpha 44)
1251  
-				`((*wserver*  . ',*wserver*)
1252  
-				  ,@excl:*required-top-level-bindings*)
1253  
-				#-(version>= 9 0 :alpha 44)
1254  
-				`((*wserver*  . ',*wserver*)
1255  
-				  ,@excl:*cl-default-special-bindings*)
1256  
-				)))
  1440
+                                :initial-bindings (initial-bindings))))
1257 1441
     (mp:process-preset proc #'http-worker-thread)
1258 1442
     (push proc (wserver-worker-threads *wserver*))
1259 1443
     (enqueue (wserver-free-worker-threads *wserver*) proc)
@@ -1500,7 +1684,7 @@ by keyword symbols and not by strings"
1500 1684
 	   (multiple-value-setq (req error-obj)
1501 1685
              (ignore-errors
1502 1686
                (with-timeout-local ((wserver-read-request-timeout *wserver*)
1503  
-                                    (debug-format :info "request timed out on read~%")
  1687
+                                    (debug-format :info "request timed out on read")
1504 1688
                                     (return-from process-connection nil))
1505 1689
                  (read-http-request sock chars-seen))))
1506 1690
 	  
@@ -1537,8 +1721,8 @@ by keyword symbols and not by strings"
1537 1721
 		  (setf (request-reply-date req) (get-universal-time))
1538 1722
 		  
1539 1723
 		  (force-output-noblock (request-socket req))
1540  
-		  
1541  
-		  (log-request req)
  1724
+
  1725
+                  (log-request req)
1542 1726
 		  
1543 1727
 		  (setq *worker-request* nil)
1544 1728
 		  (free-req-header-block req)
@@ -1548,7 +1732,7 @@ by keyword symbols and not by strings"
1548 1732
 				 (request-reply-strategy req)
1549 1733
 				 :test #'eq)
1550 1734
 		       then ; continue to use it
1551  
-			    (debug-format :info "request over, keep socket alive~%")
  1735
+			    (debug-format :info "request over, keep socket alive")
1552 1736
 			    (force-output-noblock sock)
1553 1737
 			    (setf (car chars-seen) nil)  ; for next use
1554 1738
 			    (excl::socket-bytes-written (request-socket req) 0)
@@ -1599,16 +1783,13 @@ by keyword symbols and not by strings"
1599 1783
       
1600 1784
 	    
1601 1785
 	    (debug-format  :info "got line of size ~d: " end)
1602  
-	    (if-debug-action :info
1603  
-			     (dotimes (i end) (write-char (schar buffer i) 
1604  
-							  *initial-terminal-io*))
1605  
-			     (terpri *initial-terminal-io*) (force-output *initial-terminal-io*))
1606  
-      
1607  
-	    (if* (not (eql 0 end))
  1786
+            
  1787
+            (if* (not (eql 0 end))
1608 1788
 	       then (return) ; out of loop
1609 1789
 		    ))
1610 1790
 	  
1611 1791
 	  (setq raw-cmd (buffer-substr buffer 0 end))
  1792
+          (debug-format :xmit-server-request-command "~s" raw-cmd)
1612 1793
 	  
1613 1794
 	  (multiple-value-bind (cmd uri protocol)
1614 1795
 	      (parse-http-command buffer end)
@@ -1644,7 +1825,7 @@ by keyword symbols and not by strings"
1644 1825
 		      #+ignore (null (read-request-headers req sock buffer))
1645 1826
 		      (null (new-read-request-headers req sock))
1646 1827
 		      )
1647  
-	       then (debug-format :info "no headers, ignore~%")
  1828
+	       then (debug-format :info "no headers, ignore")
1648 1829
 		    (return-from read-http-request nil))