scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

send bug report only on non-os-errors

This commit is contained in:
interp 2002-09-04 14:01:34 +00:00
parent 688d576b96
commit 5746c2b149
3 changed files with 84 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
scheme/httpd/core.scm
View File

@ -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)))

105
scheme/httpd/logging.scm
View File

@ -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))

13
scheme/packages.scm
View File

@ -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)))