sunet/scheme/httpd/logging.scm

;;; logging.scm
;;; logging functionality for web server

;;; 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.

(define do-nothing-proc (lambda a #f))

(define-record-type logging :logging
  (really-make-logging log-port log-proc
		       syslog? syslog-proc
		       dns-lookup?)
  logging?
  ;; port to perform CLF-logging
  (log-port logging-log-port set-logging-log-port!)
  ;; proc to run for CLF-logging (req status-code)
  (log-proc logging-log-proc set-logging-log-proc!)
  ;; do syslogging?
  (syslog? logging-syslog? set-logging-syslog?!)
  ;; proc to run for syslog (level fmt . args)
  (syslog-proc logging-syslog-proc set-logging-syslog-proc!)
  ;; perform dns lookups?
  (dns-lookup? logging-dns-lookup? set-logging-dns-lookup?!))

(define (make-logging)
  (really-make-logging #f
		       do-nothing-proc
		       #f
		       do-nothing-proc
		       #f))

(define logging (make-preserved-thread-fluid #f))

(define (make-fluid-selector selector)
  (lambda () (selector (thread-fluid logging))))

(define (make-fluid-setter setter)
  (lambda (value)
    (setter (thread-fluid logging) value)))

(define logging-http-log-proc (make-fluid-selector logging-log-proc))
(define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc))
(define logging-http-syslog? (make-fluid-selector logging-syslog?))
(define logging-http-log-port (make-fluid-selector logging-log-port))
(define logging-dns-lookup? (make-fluid-selector logging-dns-lookup?))

(define set-logging-http-log-proc (make-fluid-setter set-logging-log-proc!))
(define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!))
(define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!))
(define set-logging-http-log-port (make-fluid-setter set-logging-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 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)
      (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)
		(with-lock http-syslog-lock
		  (lambda ()
		    (syslog level
			    (apply format #f fmt args)))))))
      (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)))
	  (set-logging-http-log-port logport)
	  (if (string? logfile)
	      (spawn (make-logfile-rotator logfile http-log-lock)))
	  (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
	(with-lock http-log-lock
	  (lambda ()
	    (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))
		     (logging-http-log-port))
	    (force-output (logging-http-log-port)))))))


;; 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 ()
       (with-lock http-log-lock
	 (lambda ()
	   (close-output-port (logging-http-log-port))
	   (set-logging-http-log-port (open-logfile logfile))))))))

(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
		(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)
  (if (logging-dns-lookup?)
      (or (with-fatal-error-handler*
	   (lambda (condition decline)
	     (http-syslog (syslog-level debug)
			  "An error occured while resolving IP ~A: ~A"
			  remote-ip condition)
	     remote-ip)
	   (lambda ()
	     (dns-lookup-ip remote-ip)))
	  remote-ip)
      remote-ip))