diff --git a/httpd-core.scm b/httpd-core.scm index 40a7baf..9b2bd74 100644 --- a/httpd-core.scm +++ b/httpd-core.scm @@ -42,21 +42,95 @@ ;;; Configurable Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define *http-log?* #t) -(define *http-log-port* #f) -(define *http-log-lock* (make-lock)) +(define http-log (lambda a #f)) +(define http-syslog (lambda a #f)) -(define (init-http-log!) - (set! *http-log-port* (current-error-port))) +(define (init-http-log! options) + (init-http-port-log! (httpd-options-logfile options)) + (init-http-syslog! (httpd-options-syslog? options))) -(define (http-log fmt . args) - (if *http-log?* - (begin - (obtain-lock *http-log-lock*) - (apply format *http-log-port* fmt args) - (force-output *http-log-port*) - (release-lock *http-log-lock*)))) +(define (init-http-port-log! logfile) + (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))))))) + ((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; we'll use (current-error-port) instead + (else + (format (current-error-port) + "[httpd] Warning: Logfile was not specified correctly (given: ~S).~% + Logging now to stderr.\n" + logfile) + (current-error-port))))) + (if logfile ; if logging was specified, set up the logger + (set! http-log (make-http-log-proc logport))))) + ; alternative-clause: default values of *http-log?* and http-log + +(define (init-http-syslog! syslog?) + (if syslog? + (let ((http-syslog-lock (make-lock))) + (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-port) + (let ((http-log-lock (make-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)))))) + +; 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]" (date)) + (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. + ; We loose here, as the initial `/' is missing in our log. + (or http-code "-") + (or filesize "-") + (or referer "") + (or user-agent ""))) ;;; (httpd options) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -71,63 +145,67 @@ ((httpd-options-simultaneous-requests options) => make-rate-limiter) (else #f)))) - (init-http-log!) - (with-cwd - root-dir - (bind-listen-accept-loop - protocol-family/internet - ;; Why is the output socket unbuffered? So that if the client - ;; closes the connection, we won't lose when we try to close the - ;; socket by trying to flush the output buffer. - (lambda (sock addr) - (if rate-limiter - (begin - (rate-limit-block rate-limiter) - (rate-limit-open rate-limiter))) - - (with-fatal-error-handler - (lambda (c decline) - (http-log "error during connection negotiation~%") + (init-http-log! options) + (with-syslog-destination + "httpd" #f #f #f + (lambda () + (with-cwd + root-dir + (bind-listen-accept-loop + protocol-family/internet + ;; Why is the output socket unbuffered? So that if the client + ;; closes the connection, we won't lose when we try to close the + ;; socket by trying to flush the output buffer. + (lambda (sock addr) (if rate-limiter - (rate-limit-close rate-limiter))) - (call-with-values - (lambda () - (socket-address->internet-address (socket-remote-address sock))) - (lambda (host-address service-port) - (if (and rate-limiter *http-log?*) - (http-log "<~a>~a: concurrent request #~a~%" - (pid) - (format-internet-host-address host-address) - (rate-limiter-current-requests rate-limiter))) + (begin + (rate-limit-block rate-limiter) + (rate-limit-open rate-limiter))) - (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering - (fork-thread - (lambda () - (with-current-input-port - (socket:inport sock) - (with-current-output-port - (socket:outport sock) - (set-port-buffering (current-input-port) bufpol/none) - (process-toplevel-request sock host-address options))) - (if *http-log?* - (http-log "<~a>~a [closing]~%" - (pid) - (format-internet-host-address host-address))) - (with-fatal-error-handler - (lambda (c decline) - (if *http-log?* - (http-log "<~a>~a [error closing (~a)]~%" + (with-fatal-error-handler + (lambda (c decline) + (http-syslog (syslog-level notice) "error during connection negotiation~%") + (if rate-limiter + (rate-limit-close rate-limiter))) + (call-with-values + (lambda () + (socket-address->internet-address (socket-remote-address sock))) + (lambda (host-address service-port) + (if (and rate-limiter *http-log?*) + (http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%" (pid) (format-internet-host-address host-address) - c))) - (close-socket sock)) - (if rate-limiter - (rate-limit-close rate-limiter)) - (if *http-log?* - (http-log "<~a>~a [closed]~%" - (pid) - (format-internet-host-address host-address))))))))) - port)))) + (rate-limiter-current-requests rate-limiter))) + + (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering + (fork-thread + (lambda () + (with-current-input-port + (socket:inport sock) + (with-current-output-port + (socket:outport sock) + (set-port-buffering (current-input-port) bufpol/none) + (process-toplevel-request sock host-address options))) + (if *http-log?* + (http-syslog (syslog-level debug) "<~a>~a [closing]~%" + (pid) + (format-internet-host-address host-address))) + (with-fatal-error-handler + (lambda (c decline) + (if *http-log?* + (http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%" + (pid) + (format-internet-host-address host-address) + c))) + (close-socket sock)) + (if rate-limiter + (rate-limit-close rate-limiter)) + (if *http-log?* + (http-syslog (syslog-level info) "<~a>~a [closed]~%" + (pid) + (format-internet-host-address host-address))))))))) + port)))))) + ;;; Top-level http request processor ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -149,7 +227,7 @@ ;; ;; We *oughta* map non-http-errors into replies anyway. (with-fatal-error-handler (lambda (c decline) ; No call to decline - (http-log "<~a>~a: error: ~s~%" + (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%" (pid) (format-internet-host-address host-address) c) @@ -161,12 +239,12 @@ (condition-stuff c)) (with-fatal-error-handler (lambda (c decline) - (http-log "<~a>~a [error shutting down: ~s]~%" + (http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%" (pid) (format-internet-host-address host-address) c)) (shutdown-socket sock shutdown/sends+receives) - (http-log "<~a>~a [shut down]~%" + (http-syslog (syslog-level info) "<~a>~a [shut down]~%" (pid) (format-internet-host-address host-address))))) @@ -181,7 +259,9 @@ (parse-http-request sock options))) ; (1) Parse request. (handler (httpd-options-path-handler options))) - (handler (http-url:path (request:url req)) req)))) ; (2) Deal with it. + (handler (http-url:path (request:url req)) req) ; (2) Deal with it. + (http-log req http-reply/ok)))) + ;;;; HTTP request parsing @@ -236,14 +316,14 @@ (define (parse-http-request sock options) (let ((line (read-crlf-line))) - +; (display line (current-error-port)) (newline (current-error-port)) ;; Blat out some logging info. (if *http-log?* (call-with-values (lambda () (socket-address->internet-address (socket-remote-address sock))) (lambda (host-address service-port) - (http-log "<~a>~a: ~a~%" + (http-syslog (syslog-level info) "<~a>~a: ~a~%" (pid) (format-internet-host-address host-address) line)))) @@ -420,7 +500,7 @@ (apply really-send-http-error-reply reply-code req options args)))) (define (really-send-http-error-reply reply-code req options . args) - (http-log "sending error-reply ~a ~%" reply-code) + (http-log req reply-code) (let* ((message (if (pair? args) (car args))) (extras (if (pair? args) (cdr args) '())) @@ -504,6 +584,7 @@ ((= reply-code http-reply/internal-error) (format (current-error-port) "ERROR: ~A~%" message) + (http-syslog (syslog-level error) "internal-error: ~A" message) (if html-ok? (begin (generic-title) diff --git a/httpd-options.scm b/httpd-options.scm index 908d8e1..baaabc5 100644 --- a/httpd-options.scm +++ b/httpd-options.scm @@ -11,7 +11,9 @@ reported-port path-handler server-admin - simultaneous-requests) + simultaneous-requests + logfile + syslog?) httpd-options? (port httpd-options-port set-httpd-options-port!) @@ -26,8 +28,11 @@ (server-admin httpd-options-server-admin set-httpd-options-server-admin!) (simultaneous-requests httpd-options-simultaneous-requests - set-httpd-options-simultaneous-requests!)) + set-httpd-options-simultaneous-requests!) + (logfile httpd-options-logfile set-httpd-options-logfile!) + (syslog? httpd-options-syslog? set-httpd-options-syslog?!)) +; default httpd-options generation (define (make-httpd-options) (really-make-httpd-options 80 ; port "/" ; root-directory @@ -35,7 +40,14 @@ #f ; reported-port #f ; path-handler "sperber@informatik.uni-tuebingen.de" ; server-admin - #f)) ; simultaneous-requests + #f ; simultaneous-requests + "/httpd.log" ; name of the logfile + ; string: filename of logfile (directory must exist) + ; output-port: log to this port (e.g. (current-error-port)) + ; #f: no logging + #t)) ; Do syslogging? + +; creates a copy of a given httpd-option (define (copy-httpd-options options) (let ((new-options (make-httpd-options))) @@ -54,8 +66,14 @@ (set-httpd-options-simultaneous-requests! new-options (httpd-options-simultaneous-requests options)) + (set-httpd-options-logfile! new-options (httpd-options-logfile options)) + (set-httpd-options-syslog?! new-options (httpd-options-syslog? options)) new-options)) +; (make-httpd-options-transformer set-option!) -> lambda (new-value [httpd-option]) +; creates a transformer for httpd-options +; the returned procedure is called with the new value for the option +; and optionally with the httpd-option to change (define (make-httpd-options-transformer set-option!) (lambda (new-value . stuff) (let ((new-options (if (not (null? stuff)) @@ -64,6 +82,7 @@ (set-option! new-options new-value) new-options))) +; several transformers for port, root-directory, etc. (define with-port (make-httpd-options-transformer set-httpd-options-port!)) (define with-root-directory @@ -78,3 +97,40 @@ (make-httpd-options-transformer set-httpd-options-server-admin!)) (define with-simultaneous-requests (make-httpd-options-transformer set-httpd-options-simultaneous-requests!)) +(define with-logfile + (make-httpd-options-transformer set-httpd-options-logfile!)) +(define with-syslog? + (make-httpd-options-transformer set-httpd-options-syslog?!)) + +;(define (with-httpd-options options-alist) +; (let ((new-options (make-httpd-options))) +; (let loop ((options-alist options-alist)) +; (if (null? options-alist) +; new-options +; (begin +; (case (caar options-alist) +; (('port) +; (set-httpd-options-port! new-options (cdar options-alist))) +; (('root-directory) +; (set-httpd-options-root-directory! new-options (cdar options-alist))) +; (('fqdn) +; (set-httpd-options-fqdn! new-options (cdar options-alist))) +; (('reported-port) +; (set-httpd-options-reported-port! new-options (cdar options-alist))) +; (('path-handler) +; (set-httpd-options-path-handler! new-options (cdar options-alist))) +; (('server-admin) +; (set-httpd-options-server-admin! new-options (cdar options-alist))) +; (('simultaneous-requests) +; (set-httpd-options-simultaneous-requests! new-options (cdar options-alist))) +; (('logfile) +; (set-httpd-options-logfile! new-options (cdar options-alist))) +; (('syslog?) +; (set-httpd-options-syslog?! new-options (cdar options-alist))) +; (else +; (begin +; (format (current-error-port) +; "[httpd] Warning: Ignoring unknown option ~A." +; (cdar options-alist))))) +; (loop (cdr options-alist))))))) + \ No newline at end of file diff --git a/modules.scm b/modules.scm index 85e3aa5..eaa68bd 100644 --- a/modules.scm +++ b/modules.scm @@ -271,7 +271,9 @@ with-reported-port with-path-handler with-server-admin - with-simultaneous-requests)) + with-simultaneous-requests + with-logfile + with-syslog?)) (define-interface httpd-read-options-interface (export httpd-options-port @@ -280,7 +282,9 @@ httpd-options-reported-port httpd-options-path-handler httpd-options-server-admin - httpd-options-simultaneous-requests)) + httpd-options-simultaneous-requests + httpd-options-logfile + httpd-options-syslog?)) (define-interface rate-limit-interface (export make-rate-limiter @@ -319,6 +323,7 @@ sunet-utilities httpd-read-options rate-limit + string-lib ; STRING-JOIN scheme) (files httpd-core))