From 5746c2b149ea9f6a23aa72c038d78454d15cd380 Mon Sep 17 00:00:00 2001 From: interp Date: Wed, 4 Sep 2002 14:01:34 +0000 Subject: [PATCH] send bug report only on non-os-errors --- scheme/httpd/core.scm | 20 ++++---- scheme/httpd/logging.scm | 105 +++++++++++++++++++++++---------------- scheme/packages.scm | 13 +++-- 3 files changed, 84 insertions(+), 54 deletions(-) diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 89f3794..03b8643 100644 --- a/scheme/httpd/core.scm +++ b/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))) diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm index 9edb100..89ba193 100644 --- a/scheme/httpd/logging.scm +++ b/scheme/httpd/logging.scm @@ -8,35 +8,69 @@ ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. -;; default: no logging -;; initialized by init-http-log! +(define do-nothing-proc (lambda a #f)) +(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 -;; if enabled, it will look like this: -;; (lambda req status-code) -(define http-log (lambda a #f)) ; makes logging in CLF +(define logging (make-fluid #f)) -;; syslogging -;; if enabled, it will look like this: -;; (lambda (level fmt . args) -(define http-syslog (lambda a #f)) ; makes syslog -(define *http-syslog?* #f) ; trigger used to avoid - ; unnecessary computations -(define *http-log-port*) -(define (http-log-port) - *http-log-port*) -(define (set-http-log-port! port) - (set! *http-log-port* port)) -(define dns-lookup? #f) ; perform DNS lookups (write names instead of ips)? +(define (make-fluid-selector selector) + (lambda () (selector (fluid logging)))) + +(define (make-fluid-setter setter) + (lambda (value) + (setter (fluid logging) value))) + +(define logging-http-log-proc (make-fluid-selector logging:http-log-proc)) +(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc)) +(define logging-http-syslog? (make-fluid-selector logging:http-syslog?)) +(define logging-http-log-port (make-fluid-selector logging:http-log-port)) +(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 - ;; because it may generate syslog-messages + ;; syslog has to be initialized before CLF-logging + ;; 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! dns-lookup? #f))) + (set-logging-dns-lookup? #t) + (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)))))) - ; 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)))))) + (set-logging-http-log-proc (make-http-log-proc http-log-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)) - (force-output (http-log-port)) + (logging-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)) - (set-http-log-port! (open-logfile logfile)) + (close-output-port (logging-http-log-port)) + (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)) \ No newline at end of file diff --git a/scheme/packages.scm b/scheme/packages.scm index f0c51f1..7fcda8f 100644 --- a/scheme/packages.scm +++ b/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)))