diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index ff45a268e9..13cf2cf012 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -1,5 +1,6 @@ (module dispatch-log mzscheme (require (lib "url.ss" "net") + (prefix srfi-date: (lib "19.ss" "srfi")) (lib "date.ss") (lib "kw.ss") (lib "async-channel.ss") @@ -7,34 +8,67 @@ (lib "contract.ss")) (require "dispatch.ss" "../private/request-structs.ss") + (define format-req/c (request? . -> . string?)) + (provide/contract + [format-req/c contract?] + [log-format->format (symbol? . -> . format-req/c)] + [paren-format format-req/c] + [extended-format format-req/c] + [apache-default-format format-req/c] [interface-version dispatcher-interface-version?]) (provide make) (define interface-version 'v1) (define/kw (make #:key - [log-format 'parenthesized-default] - [log-path #f]) - (if log-path - (case log-format - [(parenthesized-default extended) - (let ([log-message (gen-log-message log-format log-path)]) - (lambda (conn req) - (log-message req) - (next-dispatcher)))] - [else - (lambda (conn req) - (next-dispatcher))]) - (lambda (conn req) - (next-dispatcher)))) + [format paren-format] + [log-path "log"]) + (define log-message (make-log-message log-path format)) + (lambda (conn req) + (log-message req) + (next-dispatcher))) - ; gen-log-message : sym str -> str str sym url str -> str - ; XXX: check apache log configuration formats - ; other server's include the original request line, - ; including the major and minor HTTP version numbers - ; to produce a string that is displayed into the log file - ; This is a kill-safe wait-less abstraction - (define (gen-log-message log-format log-path) + (define (log-format->format log-format) + (case log-format + [(parenthesized-default) + paren-format] + [(extended) + extended-format] + [(apache-default) + apache-default-format])) + + (define (request-line-raw req) + (format "~a ~a HTTP/1.1" + (string-upcase (symbol->string (request-method req))) + (url->string (request-uri req)))) + (define (apache-default-format req) + (define request-time (srfi-date:current-date)) + (format "~a - - [~a] \"~a\" ~a ~a~n" + (request-host-ip req) + (srfi-date:date->string request-time "~d/~b/~Y:~T ~z") + (request-line-raw req) + 200 + 512)) + + (define (paren-format req) + (format "~s~n" + (list 'from (request-client-ip req) + 'to (request-host-ip req) + 'for (url->string (request-uri req)) 'at + (date->string (seconds->date (current-seconds)) #t)))) + + (define (extended-format req) + (format "~s~n" + `((client-ip ,(request-client-ip req)) + (host-ip ,(request-host-ip req)) + (referer ,(let ([R (headers-assq* #"Referer" (request-headers/raw req))]) + (if R + (header-value R) + #f))) + (uri ,(url->string (request-uri req))) + (time ,(current-seconds))))) + + (define (make-log-message log-path format-req) (define log-ch (make-async-channel)) (define log-thread (thread/suspend-to-kill @@ -60,24 +94,7 @@ (file-stream-buffer-mode new-log-p 'line) new-log-p)) log-p)) - (display - (format "~s~n" - (case log-format - [(parenthesized-default) - (list 'from (request-client-ip req) - 'to (request-host-ip req) - 'for (url->string (request-uri req)) 'at - (date->string (seconds->date (current-seconds)) #t))] - [(extended) - `((client-ip ,(request-client-ip req)) - (host-ip ,(request-host-ip req)) - (referer ,(let ([R (headers-assq* #"Referer" (request-headers/raw req))]) - (if R - (header-value R) - #f))) - (uri ,(url->string (request-uri req))) - (time ,(current-seconds)))])) - the-log-p) + (display (format-req req) the-log-p) the-log-p))]))))))) (lambda args (thread-resume log-thread (current-custodian)) diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index dfb26f8a09..a35142b458 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -157,27 +157,50 @@ a URL that refreshes the password file, servlet cache, etc. @file{dispatchers/dispatch-log.ss} defines a dispatcher constructor for transparent logging of requests. -@; XXX Take formatting procedure -@defproc[(make [#:log-format log-format symbol? 'parenthesized-default] - [#:log-path log-path (or/c path-string? false/c) #f]) - dispatcher?]{ - If @scheme[log-path] is not @scheme[#f] and @scheme[log-format] is - @scheme['parenthesized-default] or @scheme[extended], then the request - is logged to the @scheme[log-path]. In either case, @scheme[next-dispatcher] - is invoked after this. - - If @scheme[log-format] is @scheme['parenthesized-default], then the - log looks like: @scheme[(list 'from (request-client-ip req) - 'to (request-host-ip req) - 'for (url->string (request-uri req)) 'at - (date->string (seconds->date (current-seconds)) #t))]. +@defthing[format-req/c contract?]{ + Equivalent to @scheme[(request? . -> . string?)]. +} - If @scheme[log-format] is @scheme['extended], then the log looks like: - @scheme[`((client-ip ,(request-client-ip req)) - (host-ip ,(request-host-ip req)) - (referer ,(or/c bytes? false/c)) - (uri ,(url->string (request-uri req))) - (time ,(current-seconds)))]. +@defthing[paren-format format-req/c]{ + Formats a request by: + @schemeblock[ + (format "~s~n" + (list 'from (request-client-ip req) + 'to (request-host-ip req) + 'for (url->string (request-uri req)) 'at + (date->string (seconds->date (current-seconds)) #t))) + ]} + +@defthing[extended-format format-req/c]{ + Formats a request by: + @schemeblock[ + (format "~s~n" + `((client-ip ,(request-client-ip req)) + (host-ip ,(request-host-ip req)) + (referer ,(let ([R (headers-assq* #"Referer" (request-headers/raw req))]) + (if R + (header-value R) + #f))) + (uri ,(url->string (request-uri req))) + (time ,(current-seconds)))) + ]} + +@defthing[apache-default-format format-req/c]{ + Formats a request like Apache's default. +} + +@defproc[(log-format->format [id symbol?]) + format-req/c]{ + Maps @scheme['parenthesized-default] to @scheme[paren-format], + @scheme['extended] to @scheme[extended-format], and + @scheme['apache-default] to @scheme[apache-default-format]. +} + +@defproc[(make [#:format format format-req/c paren-format] + [#:log-path log-path path-string? "log"]) + dispatcher?]{ + Logs requests to @scheme[log-path] by using @scheme[format] to format the requests. + Then invokes @scheme[next-dispatcher]. } @; ------------------------------------------------------------ diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 6bf07e146d..e5495474cb 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -51,7 +51,7 @@ (define (host-info->dispatcher host-info) (sequencer:make (timeout:make initial-connection-timeout) - (log:make #:log-format (host-log-format host-info) + (log:make #:format (log:log-format->format (host-log-format host-info)) #:log-path (host-log-path host-info)) (let-values ([(update-password-cache! password-check) (passwords:make #:password-file (host-passwords host-info)