Added enhanced logging possibilities to httpd

httpd-core.scm

@@ -42,21 +42,95 @@
 ;;; Configurable Variables
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define *http-log?* #t)
+(define http-log (lambda a #f))
-(define *http-log-port* #f)
+(define http-syslog (lambda a #f))
-(define *http-log-lock* (make-lock))
 
-(define (init-http-log!)
+(define (init-http-log! options)
-  (set! *http-log-port* (current-error-port)))
+  (init-http-port-log! (httpd-options-logfile options))
+  (init-http-syslog! (httpd-options-syslog? options)))
 
-(define (http-log fmt . args)
+(define (init-http-port-log! logfile)
-  (if *http-log?*
+  (let ((logport 
-      (begin 
+	 (cond
-	(obtain-lock *http-log-lock*)
+	  ((string? logfile)            ; try to open logfile for appending (output)
-	(apply format *http-log-port* fmt args)
+	   (call-with-current-continuation
-	(force-output *http-log-port*)
+	    (lambda (exit)
-	(release-lock *http-log-lock*))))
+	      (with-errno-handler*
+	       (lambda (errno packet)
+		 (format (current-error-port) 
+			 "[httpd] Warning: An error occured while opening ~S for writing (~A).
+                 Logging now to stderr.~%"
+			 logfile
+			 (car packet))
+		 (exit (current-error-port)))
+	       (lambda ()
+		 (open-output-file logfile 
+				   (bitwise-ior open/create open/append)))))))
+	  ((output-port? logfile)       ; we were given an output port, so let's use it
+	   logfile)
+	  ((eq? logfile #f)             ; no logging demanded
+	   #f)
+	; unexpected value of logfile; we'll use (current-error-port) instead
+	  (else
+	   (format (current-error-port)
+		   "[httpd] Warning: Logfile was not specified correctly (given: ~S).~%
+                 Logging now to stderr.\n"
+		   logfile)
+	   (current-error-port)))))
 
+    (if logfile                         ; if logging was specified, set up the logger
+	(set! http-log (make-http-log-proc logport)))))
+	; alternative-clause: default values of *http-log?* and http-log
+
+(define (init-http-syslog! syslog?)
+  (if syslog?
+      (let ((http-syslog-lock (make-lock)))
+	(set! http-syslog
+	      (lambda (level fmt . args)
+		(obtain-lock http-syslog-lock)
+		(syslog level
+			(apply format #f fmt args))
+		(release-lock http-syslog-lock))))))
+	
+(define (make-http-log-proc http-log-port)
+  (let ((http-log-lock (make-lock)))
+;    (display "--- MARK (server started) ---\n" http-log-port)
+    (lambda (req reply-code)
+      (if req
+	  (begin
+	    (obtain-lock http-log-lock)
+	    (display (make-CLF
+		      (receive (host-address _) 
+			       (socket-address->internet-address 
+				(socket-remote-address (request:socket req)))
+			       (format-internet-host-address host-address))
+		      (request:method req)                         ; request method
+		      (uri-path-list->path 
+		       (http-url:path (request:url req)))          ; requested file
+		      (version->string (request:version req))      ; protocol version
+		      reply-code
+		      23                                           ; filesize (unknown)
+		      (get-header (request:headers req) 'referer)
+		      (get-header (request:headers req) 'user-agent))
+		     http-log-port)
+	    (force-output http-log-port)
+	    (release-lock http-log-lock))))))
+  
+; returns a string for a CLF entry (Common Log Format)
+; note: till now, we do not log the user's time zone code
+(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
+  (format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
+		(or remote-ip "-")
+		(format-date "[~d/~b/~Y:~H:~M:~S]" (date))
+		(string-join (list request-type requested-file protocol))
+		; Unfortunately, we first split the request line into 
+		; method/request-type etc. and put it together here.
+		; Files conform to CLF are expected to print the original line.
+		; We loose here, as the initial `/' is missing in our log.
+		(or http-code "-")
+		(or filesize "-")
+		(or referer "")
+		(or user-agent "")))
 
 ;;; (httpd options)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -71,63 +145,67 @@
 	  ((httpd-options-simultaneous-requests options)
 	   => make-rate-limiter)
 	  (else #f))))
-    (init-http-log!)
+    (init-http-log! options)
-    (with-cwd
+    (with-syslog-destination
-     root-dir
+     "httpd" #f #f #f
-     (bind-listen-accept-loop
+     (lambda ()
-      protocol-family/internet
+       (with-cwd
-      ;; Why is the output socket unbuffered? So that if the client
+	root-dir
-      ;; closes the connection, we won't lose when we try to close the
+	(bind-listen-accept-loop
-      ;; socket by trying to flush the output buffer.
+	 protocol-family/internet
-      (lambda (sock addr)
+	 ;; Why is the output socket unbuffered? So that if the client
-	(if rate-limiter
+	 ;; closes the connection, we won't lose when we try to close the
-	    (begin
+	 ;; socket by trying to flush the output buffer.
-	      (rate-limit-block rate-limiter)
+	 (lambda (sock addr)
-	      (rate-limit-open rate-limiter)))
-
-	(with-fatal-error-handler
-	 (lambda (c decline)
-	   (http-log "error during connection negotiation~%")
 	   (if rate-limiter
-	       (rate-limit-close rate-limiter)))
+	       (begin
-	 (call-with-values
+		 (rate-limit-block rate-limiter)
-	  (lambda ()
+		 (rate-limit-open rate-limiter)))
-	    (socket-address->internet-address (socket-remote-address sock)))
-	  (lambda (host-address service-port)
-	    (if (and rate-limiter *http-log?*)
-		(http-log "<~a>~a: concurrent request #~a~%"
-			  (pid)
-			  (format-internet-host-address host-address)
-			  (rate-limiter-current-requests rate-limiter)))
 
-	    (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+	   (with-fatal-error-handler
-	    (fork-thread 
+	    (lambda (c decline)
-	     (lambda ()	
+	      (http-syslog (syslog-level notice) "error during connection negotiation~%")
-	       (with-current-input-port 
+	      (if rate-limiter
-		(socket:inport sock)
+		  (rate-limit-close rate-limiter)))
-		(with-current-output-port 
+	    (call-with-values
-		 (socket:outport sock)
+	     (lambda ()
-		 (set-port-buffering (current-input-port) bufpol/none)
+	       (socket-address->internet-address (socket-remote-address sock)))
-		 (process-toplevel-request sock host-address options)))
+	     (lambda (host-address service-port)
-	       (if *http-log?*
+	       (if (and rate-limiter *http-log?*)
-		   (http-log "<~a>~a [closing]~%"
+		   (http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
-			     (pid)
-			     (format-internet-host-address host-address)))
-	       (with-fatal-error-handler
-		(lambda (c decline)
-		  (if *http-log?*
-		      (http-log "<~a>~a [error closing (~a)]~%"
 				(pid)
 				(format-internet-host-address host-address)
-				c)))
+				(rate-limiter-current-requests rate-limiter)))
-		(close-socket sock))
+
-	       (if rate-limiter
+	       (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
-		   (rate-limit-close rate-limiter))
+	       (fork-thread 
-	       (if *http-log?*
+		(lambda ()	
-		   (http-log "<~a>~a [closed]~%"
+		  (with-current-input-port 
-			     (pid)
+		   (socket:inport sock)
-			     (format-internet-host-address host-address)))))))))
+		   (with-current-output-port 
-      port))))
+		    (socket:outport sock)
+		    (set-port-buffering (current-input-port) bufpol/none)
+		    (process-toplevel-request sock host-address options)))
+		  (if *http-log?*
+		      (http-syslog (syslog-level debug) "<~a>~a [closing]~%"
+				   (pid)
+				   (format-internet-host-address host-address)))
+		  (with-fatal-error-handler
+		   (lambda (c decline)
+		     (if *http-log?*
+			 (http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%"
+				      (pid)
+				      (format-internet-host-address host-address)
+				      c)))
+		   (close-socket sock))
+		  (if rate-limiter
+		      (rate-limit-close rate-limiter))
+		  (if *http-log?*
+		      (http-syslog (syslog-level info) "<~a>~a [closed]~%"
+				   (pid)
+				   (format-internet-host-address host-address)))))))))
+	 port))))))
+
 
 ;;; Top-level http request processor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -149,7 +227,7 @@
   ;;
   ;; We *oughta* map non-http-errors into replies anyway.
   (with-fatal-error-handler (lambda (c decline)		; No call to decline
-			      (http-log "<~a>~a: error: ~s~%"
+			      (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
 					(pid)
 					(format-internet-host-address host-address)
 					c)
@@ -161,12 +239,12 @@
 					 (condition-stuff c))
 				  (with-fatal-error-handler
 				   (lambda (c decline)
-				     (http-log "<~a>~a [error shutting down: ~s]~%"
+				     (http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
 					       (pid)
 					       (format-internet-host-address host-address)
 					       c))
 				   (shutdown-socket sock shutdown/sends+receives)
-				   (http-log "<~a>~a [shut down]~%"
+				   (http-syslog (syslog-level info) "<~a>~a [shut down]~%"
 					     (pid)
 					     (format-internet-host-address host-address)))))
 
@@ -181,7 +259,9 @@
 		 (parse-http-request sock options)))	   ; (1) Parse request.
 	  (handler
 	   (httpd-options-path-handler options)))
-      (handler (http-url:path (request:url req)) req))))   ; (2) Deal with it.
+      (handler (http-url:path (request:url req)) req)   ; (2) Deal with it.
+      (http-log req http-reply/ok))))
+
 
 
 ;;;; HTTP request parsing
@@ -236,14 +316,14 @@
 
 (define (parse-http-request sock options)
   (let ((line (read-crlf-line)))
-
+;    (display line (current-error-port)) (newline (current-error-port))
     ;; Blat out some logging info.
     (if *http-log?*
 	(call-with-values
 	 (lambda ()
 	   (socket-address->internet-address (socket-remote-address sock)))
 	 (lambda (host-address service-port)
-	   (http-log "<~a>~a: ~a~%"
+	   (http-syslog (syslog-level info) "<~a>~a: ~a~%"
 		     (pid)
 		     (format-internet-host-address host-address)
 		     line))))
@@ -420,7 +500,7 @@
 		   (apply really-send-http-error-reply reply-code req options args))))
 
 (define (really-send-http-error-reply reply-code req options . args)
-  (http-log "sending error-reply ~a ~%" reply-code)
+  (http-log req reply-code)
 
   (let* ((message (if (pair? args) (car args)))
 	 (extras  (if (pair? args) (cdr args) '()))
@@ -504,6 +584,7 @@
 
       ((= reply-code http-reply/internal-error)
        (format (current-error-port) "ERROR: ~A~%" message)
+       (http-syslog (syslog-level error) "internal-error: ~A" message)
        (if html-ok? 
 	   (begin
 	     (generic-title)

httpd-options.scm

@@ -11,7 +11,9 @@
 			     reported-port
 			     path-handler
 			     server-admin
-			     simultaneous-requests)
+			     simultaneous-requests
+			     logfile
+			     syslog?)
   httpd-options?
   (port httpd-options-port
 	set-httpd-options-port!)
@@ -26,8 +28,11 @@
   (server-admin httpd-options-server-admin
 		set-httpd-options-server-admin!)
   (simultaneous-requests httpd-options-simultaneous-requests
-			 set-httpd-options-simultaneous-requests!))
+			 set-httpd-options-simultaneous-requests!)
+  (logfile httpd-options-logfile set-httpd-options-logfile!)
+  (syslog? httpd-options-syslog? set-httpd-options-syslog?!))
 
+; default httpd-options generation
 (define (make-httpd-options)
   (really-make-httpd-options 80		; port
 			     "/"	; root-directory
@@ -35,7 +40,14 @@
 			     #f		; reported-port
 			     #f		; path-handler
 			     "sperber@informatik.uni-tuebingen.de" ; server-admin
-			     #f))	; simultaneous-requests
+			     #f	        ; simultaneous-requests
+			     "/httpd.log"  ; name of the logfile
+                            ; string: filename of logfile (directory must exist)
+                            ; output-port: log to this port (e.g. (current-error-port))
+                            ; #f: no logging
+			     #t))      ; Do syslogging?
+
+; creates a copy of a given httpd-option
 
 (define (copy-httpd-options options)
   (let ((new-options (make-httpd-options)))
@@ -54,8 +66,14 @@
     (set-httpd-options-simultaneous-requests!
      new-options
      (httpd-options-simultaneous-requests options))
+    (set-httpd-options-logfile! new-options (httpd-options-logfile options))
+    (set-httpd-options-syslog?! new-options (httpd-options-syslog? options))
     new-options))
 
+; (make-httpd-options-transformer set-option!) -> lambda (new-value [httpd-option])
+; creates a transformer for httpd-options
+; the returned procedure is called with the new value for the option
+; and optionally with the httpd-option to change
 (define (make-httpd-options-transformer set-option!)
   (lambda (new-value . stuff)
     (let ((new-options (if (not (null? stuff))
@@ -64,6 +82,7 @@
       (set-option! new-options new-value)
       new-options)))
 
+; several transformers for port, root-directory, etc.
 (define with-port
   (make-httpd-options-transformer set-httpd-options-port!))
 (define with-root-directory
@@ -78,3 +97,40 @@
   (make-httpd-options-transformer set-httpd-options-server-admin!))
 (define with-simultaneous-requests
   (make-httpd-options-transformer set-httpd-options-simultaneous-requests!))
+(define with-logfile
+  (make-httpd-options-transformer set-httpd-options-logfile!))
+(define with-syslog?
+  (make-httpd-options-transformer set-httpd-options-syslog?!))
+
+;(define (with-httpd-options options-alist)
+;  (let ((new-options (make-httpd-options)))
+;    (let loop ((options-alist options-alist))
+;      (if (null? options-alist)
+;	  new-options
+;	  (begin
+;	    (case (caar options-alist)
+;	      (('port)
+;	       (set-httpd-options-port! new-options (cdar options-alist)))
+;	      (('root-directory)
+;	       (set-httpd-options-root-directory! new-options (cdar options-alist)))
+;	      (('fqdn)
+;	       (set-httpd-options-fqdn! new-options (cdar options-alist)))
+;	      (('reported-port)
+;	       (set-httpd-options-reported-port! new-options (cdar options-alist)))
+;	      (('path-handler)
+;	       (set-httpd-options-path-handler! new-options (cdar options-alist)))
+;	      (('server-admin)
+;	       (set-httpd-options-server-admin! new-options (cdar options-alist)))
+;	      (('simultaneous-requests)
+;	       (set-httpd-options-simultaneous-requests! new-options (cdar options-alist)))
+;	      (('logfile)
+;	       (set-httpd-options-logfile! new-options (cdar options-alist)))
+;	      (('syslog?)
+;	       (set-httpd-options-syslog?! new-options (cdar options-alist)))
+;	      (else
+;	       (begin
+;		 (format (current-error-port) 
+;			 "[httpd] Warning: Ignoring unknown option ~A."
+;			 (cdar options-alist)))))
+;	    (loop (cdr options-alist)))))))
+  

modules.scm

@@ -271,7 +271,9 @@
 	  with-reported-port
 	  with-path-handler
 	  with-server-admin
-	  with-simultaneous-requests))
+	  with-simultaneous-requests
+	  with-logfile
+	  with-syslog?))
 
 (define-interface httpd-read-options-interface
   (export httpd-options-port
@@ -280,7 +282,9 @@
 	  httpd-options-reported-port
 	  httpd-options-path-handler
 	  httpd-options-server-admin
-	  httpd-options-simultaneous-requests))
+	  httpd-options-simultaneous-requests
+	  httpd-options-logfile
+	  httpd-options-syslog?))
 
 (define-interface rate-limit-interface
   (export make-rate-limiter
@@ -319,6 +323,7 @@
 	sunet-utilities
 	httpd-read-options
 	rate-limit
+	string-lib     ; STRING-JOIN
 	scheme)
   (files httpd-core))