Added enhanced logging possibilities to httpd

This commit is contained in:
interp 2002-03-25 11:35:05 +00:00
parent 540cb7a7e6
commit ad124d61e1
3 changed files with 219 additions and 77 deletions

View File

@ -42,21 +42,95 @@
;;; Configurable Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *http-log?* #t)
(define *http-log-port* #f)
(define *http-log-lock* (make-lock))
(define http-log (lambda a #f))
(define http-syslog (lambda a #f))
(define (init-http-log!)
(set! *http-log-port* (current-error-port)))
(define (init-http-log! options)
(init-http-port-log! (httpd-options-logfile options))
(init-http-syslog! (httpd-options-syslog? options)))
(define (http-log fmt . args)
(if *http-log?*
(begin
(obtain-lock *http-log-lock*)
(apply format *http-log-port* fmt args)
(force-output *http-log-port*)
(release-lock *http-log-lock*))))
(define (init-http-port-log! logfile)
(let ((logport
(cond
((string? logfile) ; try to open logfile for appending (output)
(call-with-current-continuation
(lambda (exit)
(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!)
(with-cwd
root-dir
(bind-listen-accept-loop
protocol-family/internet
;; Why is the output socket unbuffered? So that if the client
;; closes the connection, we won't lose when we try to close the
;; socket by trying to flush the output buffer.
(lambda (sock addr)
(if rate-limiter
(begin
(rate-limit-block rate-limiter)
(rate-limit-open rate-limiter)))
(with-fatal-error-handler
(lambda (c decline)
(http-log "error during connection negotiation~%")
(init-http-log! options)
(with-syslog-destination
"httpd" #f #f #f
(lambda ()
(with-cwd
root-dir
(bind-listen-accept-loop
protocol-family/internet
;; Why is the output socket unbuffered? So that if the client
;; closes the connection, we won't lose when we try to close the
;; socket by trying to flush the output buffer.
(lambda (sock addr)
(if rate-limiter
(rate-limit-close rate-limiter)))
(call-with-values
(lambda ()
(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)))
(begin
(rate-limit-block rate-limiter)
(rate-limit-open rate-limiter)))
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
(fork-thread
(lambda ()
(with-current-input-port
(socket:inport sock)
(with-current-output-port
(socket:outport sock)
(set-port-buffering (current-input-port) bufpol/none)
(process-toplevel-request sock host-address options)))
(if *http-log?*
(http-log "<~a>~a [closing]~%"
(pid)
(format-internet-host-address host-address)))
(with-fatal-error-handler
(lambda (c decline)
(if *http-log?*
(http-log "<~a>~a [error closing (~a)]~%"
(with-fatal-error-handler
(lambda (c decline)
(http-syslog (syslog-level notice) "error during connection negotiation~%")
(if rate-limiter
(rate-limit-close rate-limiter)))
(call-with-values
(lambda ()
(socket-address->internet-address (socket-remote-address sock)))
(lambda (host-address service-port)
(if (and rate-limiter *http-log?*)
(http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
(pid)
(format-internet-host-address host-address)
c)))
(close-socket sock))
(if rate-limiter
(rate-limit-close rate-limiter))
(if *http-log?*
(http-log "<~a>~a [closed]~%"
(pid)
(format-internet-host-address host-address)))))))))
port))))
(rate-limiter-current-requests rate-limiter)))
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
(fork-thread
(lambda ()
(with-current-input-port
(socket:inport sock)
(with-current-output-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)

View File

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

View File

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