Added enhanced logging possibilities to httpd
This commit is contained in:
interp
parent
540cb7a7e6
commit
ad124d61e1
223
httpd-core.scm
223
httpd-core.scm
|
|
@ -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
|
||||
(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 ()
|
||||
(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)]~%"
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue