scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added logfile rotation on SIGUSR1.

This commit is contained in:
mainzelm 2002-05-08 12:04:41 +00:00
parent 5c72a6dad2
commit 18c056e01e
1 changed files with 57 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
httpd-core.scm
View File

@ -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,29 +91,52 @@
(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