From 18c056e01e34f49e0a8f6765fdcc21bf78a65330 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 8 May 2002 12:04:41 +0000
Subject: [PATCH] Added logfile rotation on SIGUSR1.

---
 httpd-core.scm | 94 ++++++++++++++++++++++++++++++--------------------
 1 file changed, 57 insertions(+), 37 deletions(-)

diff --git a/httpd-core.scm b/httpd-core.scm
index c41aa5e..d075267 100644
--- a/httpd-core.scm
+++ b/httpd-core.scm
@@ -45,6 +45,11 @@
 (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)
   (init-http-port-log! (httpd-options-logfile options))
@@ -54,19 +59,7 @@
   (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)))))))
+	   (open-logfile logfile))
 	  ((output-port? logfile)       ; we were given an output port, so let's use it
 	   logfile)
 	  ((eq? logfile #f)             ; no logging demanded
@@ -80,7 +73,11 @@
 	   (current-error-port)))))
 
     (if logfile                         ; if logging was specified, set up the logger
-	(set! http-log (make-http-log-proc logport)))))
+	(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?)
@@ -94,30 +91,53 @@
 			(apply format #f fmt args))
 		(release-lock http-syslog-lock))))))
 	
-(define (make-http-log-proc http-log-port)
-  (let ((http-log-lock (make-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))))))
-  
+  (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)))))
+
+(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)
+     (format (current-error-port) 
+	     "[httpd] Warning: An error occured while opening ~S for writing (~A).
+                 Logging now to stderr.~%"
+	     logfile
+	     (car packet))
+     ((current-error-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)