send bug report only on non-os-errors

scheme/httpd/core.scm

@@ -61,7 +61,7 @@
 	     (lambda ()
 	       (socket-address->internet-address (socket-remote-address sock)))
 	     (lambda (host-address service-port)
-	       (if (and rate-limiter *http-syslog?*)
+	       (if (and rate-limiter (http-syslog?))
 		   (http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
 				(pid)
 				(format-internet-host-address host-address)
@@ -72,13 +72,13 @@
 		(lambda ()	
 		  (set-port-buffering (current-input-port) bufpol/none)
 		  (process-toplevel-request sock host-address options)
-		  (if *http-syslog?*
+		  (if (http-syslog?)
 		      (http-syslog (syslog-level debug) "<~a>~a [closing]~%"
 				   (pid)
 				   (format-internet-host-address host-address)))
 		  (with-fatal-error-handler
 		   (lambda (c decline)
-		     (if *http-syslog?*
+		     (if (http-syslog?)
 			 (http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%"
 				      (pid)
 				      (format-internet-host-address host-address)
@@ -86,7 +86,7 @@
 		   (close-socket sock))
 		  (if rate-limiter
 		      (rate-limit-close rate-limiter))
-		  (if *http-syslog?*
+		  (if (http-syslog?)
 		      (http-syslog (syslog-level info) "<~a>~a [closed]~%"
 				   (pid)
 				   (format-internet-host-address host-address)))))))))
@@ -153,15 +153,17 @@
 			    #f		; No request yet.	
 			    "Request parsing error -- report to client maintainer."
 			    (condition-stuff c))))
-	    ((error? c)
+	    ((not (and (exception? c)
+		       (eq? (exception-reason c)
+			    (enum exception os-error))))
+
 	     ;; try to send bug report to client
 	     (values #f
 		     (apply make-http-error-response http-status/internal-error 
 			    #f		; don't know
-			    (format #f
+			    "Internal error occured while processing request"
-				    "Internal error occured while processing request")
 			    c)))
-	    (else			; there's no else...
+	    (else
 	     (decline))))
 	 (lambda ()
 	   (let ((initial-req (parse-http-request sock options)))
@@ -219,7 +221,7 @@
 (define (parse-http-request sock options)
   (let ((line (read-crlf-line (socket:inport sock))))
     ;; Blat out some logging info.
-    (if *http-syslog?*
+    (if (http-syslog?)
 	(call-with-values
 	 (lambda ()
 	   (socket-address->internet-address (socket-remote-address sock)))

scheme/httpd/logging.scm

@@ -8,35 +8,69 @@
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
-;; default: no logging
+(define do-nothing-proc (lambda a #f))
-;; initialized by init-http-log!
+(define-record logging
+  (http-log-port #f)			;port to perform CLF-logging
+  (http-log-proc do-nothing-proc)	;proc to run for CLF-logging (req status-code)
+  (http-syslog? #f)			;do syslogging?
+  (http-syslog-proc do-nothing-proc)	;proc to run for syslog (level fmt . args)
+  (dns-lookup? #f))			;perform dns-lookups?
 
-;; CLF-logging
+(define logging (make-fluid #f))
-;; if enabled, it will look like this:
-;;      (lambda req status-code)
-(define http-log (lambda a #f))      ; makes logging in CLF
 
-;; syslogging
+(define (make-fluid-selector selector)
-;; if enabled, it will look like this:
+  (lambda () (selector (fluid logging))))
-;; 	      (lambda (level fmt . args)
+
-(define http-syslog (lambda a #f))   ; makes syslog
+(define (make-fluid-setter setter)
-(define *http-syslog?* #f)           ; trigger used to avoid
+  (lambda (value)
-                                     ;  unnecessary computations
+    (setter (fluid logging) value)))
-(define *http-log-port*)
+
-(define (http-log-port)
+(define logging-http-log-proc (make-fluid-selector logging:http-log-proc))
-  *http-log-port*)
+(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc))
-(define (set-http-log-port! port)
+(define logging-http-syslog? (make-fluid-selector logging:http-syslog?))
-  (set! *http-log-port* port))
+(define logging-http-log-port (make-fluid-selector logging:http-log-port))
-(define dns-lookup? #f)			; perform DNS lookups (write names instead of ips)?
+(define logging-dns-lookup? (make-fluid-selector logging:dns-lookup?))
+
+(define set-logging-http-log-proc (make-fluid-setter set-logging:http-log-proc))
+(define set-logging-http-syslog-proc (make-fluid-setter set-logging:http-syslog-proc))
+(define set-logging-http-syslog? (make-fluid-setter set-logging:http-syslog?))
+(define set-logging-http-log-port (make-fluid-setter set-logging:http-log-port))
+(define set-logging-dns-lookup? (make-fluid-setter set-logging:dns-lookup?))
+
+(define http-syslog
+  (lambda a
+    (apply (logging-http-syslog-proc) a)))
+
+(define http-log
+  (lambda a
+    (apply (logging-http-log-proc) a)))
+
+(define (http-syslog?)
+  (logging-http-syslog?))
 
 (define (init-http-log! options)
-  ;; syslog has to be initialized befor CLF-logging
+  ;; syslog has to be initialized before CLF-logging
-  ;; because it may generate syslog-messages
+  ;; because the latter may generate syslog-messages
+  (set! logging (make-fluid (make-logging)))
   (init-http-syslog! (httpd-options-syslog? options))
   (init-http-port-log! (httpd-options-logfile options))
   (if (httpd-options-resolve-ips? options)
-      (set! dns-lookup? #t)
+      (set-logging-dns-lookup? #t)
-      (set! dns-lookup? #f)))
+      (set-logging-dns-lookup? #f)))
+
+(define (init-http-syslog! syslog?)
+  (if syslog?
+      (let ((http-syslog-lock (make-lock)))
+	(set-logging-http-syslog? #t)
+	(set-logging-http-syslog-proc
+	      (lambda (level fmt . args)
+		(obtain-lock http-syslog-lock)
+		(syslog level
+			(apply format #f fmt args))
+		(release-lock http-syslog-lock))))
+      (begin
+	(set-logging-http-syslog? #f)
+	(set-logging-http-syslog-proc do-nothing-proc))))
 
 (define (init-http-port-log! logfile)
   (let ((logport 
@@ -57,25 +91,12 @@
 
     (if logfile                         ; if logging was specified, set up the logger
 	(let ((http-log-lock (make-lock)))
-	  (set-http-log-port! logport)
+	  (set-logging-http-log-port logport)
 	  (if (string? logfile)
 	      (spawn (make-logfile-rotator logfile http-log-lock)))
-	  (set! http-log (make-http-log-proc http-log-lock))))))
+	  (set-logging-http-log-proc (make-http-log-proc http-log-lock))))))
-	; alternative-clause: default values of *http-syslog?* and http-log
-
-(define (init-http-syslog! syslog?)
-  (if syslog?
-      (let ((http-syslog-lock (make-lock)))
-	(set! *http-syslog?* #t)
-	(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-lock)
-;    (display "--- MARK (server started) ---\n" http-log-port)
   (lambda (req status-code)
     (if req
 	(begin
@@ -93,8 +114,8 @@
 		    23			; filesize (unknown)
 		    (get-header (request:headers req) 'referer)
 		    (get-header (request:headers req) 'user-agent))
-		   (http-log-port))
+		   (logging-http-log-port))
-	  (force-output (http-log-port))
+	  (force-output (logging-http-log-port))
 	  (release-lock http-log-lock)))))
 
 
@@ -106,8 +127,8 @@
      interrupt/usr1
      (lambda ()
        (obtain-lock http-log-lock)
-       (close-output-port (http-log-port))
+       (close-output-port (logging-http-log-port))
-       (set-http-log-port! (open-logfile logfile))
+       (set-logging-http-log-port (open-logfile logfile))
        (release-lock http-log-lock)))))
 
 (define (open-logfile logfile)	      
@@ -143,7 +164,7 @@
 
 
 (define (maybe-dns-lookup remote-ip)
-  (if dns-lookup?
+  (if (logging-dns-lookup?)
       (or (dns-lookup-ip remote-ip)
 	  remote-ip)
       remote-ip))

scheme/packages.scm

@@ -290,9 +290,11 @@
 
 (define-interface httpd-logging-interface
   (export init-http-log!
-	  *http-syslog?*
+	  http-syslog?
 	  http-syslog
-	  http-log))
+	  http-log
+	  logging
+	  make-logging))
 
 (define-interface httpd-request-interface
   (export make-request 	; HTTP request
@@ -690,6 +692,9 @@
 	dns				; dns-lookup-ip
 	sunet-utilities                 ; socket-address->string 
 	locks				; make-lock et al.
+	fluids				; let-fluid
+	enumerated			; enum
+	architecture			; exception, os-error
 
 	handle-fatal-error
 	httpd-read-options
@@ -733,11 +738,13 @@
 	httpd-request			; request record
 	formats				; format
 	format-net			; format-internet-host-address
-	srfi-13			; string-join, string-trim
+	srfi-13				; string-join, string-trim
 	rfc822				; get-header
 	sunet-utilities			; on-interrupt
 	threads				; spawn
 	dns				; dns-lookup-ip
+	defrec-package			; define-record
+	fluids				; make-fluid et al.
 	scsh
 	scheme)
   (files (httpd logging)))