send bug report only on non-os-errors
This commit is contained in:
parent
688d576b96
commit
5746c2b149
|
@ -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)))
|
||||
|
|
|
@ -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))
|
|
@ -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
|
||||
|
@ -738,6 +743,8 @@
|
|||
sunet-utilities ; on-interrupt
|
||||
threads ; spawn
|
||||
dns ; dns-lookup-ip
|
||||
defrec-package ; define-record
|
||||
fluids ; make-fluid et al.
|
||||
scsh
|
||||
scheme)
|
||||
(files (httpd logging)))
|
||||
|
|
Loading…
Reference in New Issue