;;; logging.scm
;;; logging functionality for web server
;;; 2002, Andreas Bernauer, Martin Gasbichler

;; default: no logging
;; initialized by init-http-log!

;; CLF-logging
;; if enabled, it will look like this:
;;      (lambda req reply-code)
(define http-log (lambda a #f))      ; makes logging in CLF

;; 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 (init-http-log! options)
  ;; syslog has to be initialized befor CLF-logging
  ;; because it may generate syslog-messages
  (init-http-syslog! (httpd-options-syslog? options))
  (init-http-port-log! (httpd-options-logfile options)))

(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-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))))))
	
(define (make-http-log-proc http-log-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)))))


;; 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)
       (close-output-port (http-log-port))
       (set-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 remote-ip "-")
		(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date))     ; +0000 as we don't know
		(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.
		(or http-code "-")
		(or filesize "-")
		(if (string? referer) (string-trim referer) "")
		(if (string? user-agent) 
		    (string-trim user-agent char-set:whitespace) 
		    "")))