sunet/scheme/httpd/logging.scm

169 lines
5.9 KiB
Scheme
Raw Normal View History

;;; logging.scm
;;; logging functionality for web server
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Martin Gasbichler.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
2002-09-04 10:01:34 -04:00
(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?
(define logging (make-preserved-thread-fluid #f))
2002-09-04 10:01:34 -04:00
(define (make-fluid-selector selector)
(lambda () (selector (thread-fluid logging))))
2002-09-04 10:01:34 -04:00
(define (make-fluid-setter setter)
(lambda (value)
(setter (thread-fluid logging) value)))
2002-09-04 10:01:34 -04:00
(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)
2002-09-04 10:01:34 -04:00
;; syslog has to be initialized before CLF-logging
;; because the latter may generate syslog-messages
(init-http-syslog! (httpd-options-syslog? options))
(init-http-port-log! (httpd-options-logfile options))
(if (httpd-options-resolve-ips? options)
2002-09-04 10:01:34 -04:00
(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
(cond
((string? logfile) ; try to open logfile for appending (output)
(open-logfile logfile))
((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;
(else
(http-syslog
(syslog-level warning)
"[httpd] Warning: Logfile was not specified correctly (given: ~S).~% No CLF logging."
logfile)
(make-null-output-port)))))
(if logfile ; if logging was specified, set up the logger
(let ((http-log-lock (make-lock)))
2002-09-04 10:01:34 -04:00
(set-logging-http-log-port logport)
(if (string? logfile)
(spawn (make-logfile-rotator logfile http-log-lock)))
2002-09-04 10:01:34 -04:00
(set-logging-http-log-proc (make-http-log-proc http-log-lock))))))
(define (make-http-log-proc http-log-lock)
(lambda (req status-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
status-code
23 ; filesize (unknown)
(get-header (request:headers req) 'referer)
(get-header (request:headers req) 'user-agent))
2002-09-04 10:01:34 -04:00
(logging-http-log-port))
(force-output (logging-http-log-port))
(release-lock http-log-lock)))))
;; does the logfile rotation on signal USR1
(define (make-logfile-rotator logfile http-log-lock)
(set-interrupt-handler interrupt/usr1 #f)
(lambda ()
(on-interrupt
interrupt/usr1
(lambda ()
(obtain-lock http-log-lock)
2002-09-04 10:01:34 -04:00
(close-output-port (logging-http-log-port))
(set-logging-http-log-port (open-logfile logfile))
(release-lock http-log-lock)))))
(define (open-logfile logfile)
(with-errno-handler*
(lambda (errno packet)
(http-syslog (syslog-level warning)
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
logfile
(car packet))
(make-null-output-port))
(lambda ()
(open-output-file logfile
(bitwise-ior open/create open/append)))))
; 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 (maybe-dns-lookup remote-ip) "-")
(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date)) ; +0000 as we don't know
2002-08-22 09:19:57 -04:00
(string-join (list request-type
(string-append "/" 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.
(or http-code "-")
(or filesize "-")
(if (string? referer) (string-trim referer) "")
(if (string? user-agent)
(string-trim user-agent char-set:whitespace)
"")))
(define (maybe-dns-lookup remote-ip)
2002-09-04 10:01:34 -04:00
(if (logging-dns-lookup?)
(or (dns-lookup-ip remote-ip)
remote-ip)
remote-ip))