Updating logging

svn: r6735

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]
+                   [format paren-format]
-                   [log-path #f])
+                   [log-path "log"])
-    (if log-path
+    (define log-message (make-log-message log-path format))
-        (case log-format
+    (lambda (conn req)
-          [(parenthesized-default extended)
+      (log-message req)
-           (let ([log-message (gen-log-message log-format log-path)])
+      (next-dispatcher)))
-             (lambda (conn req)
-               (log-message req)
-               (next-dispatcher)))]
-          [else
-           (lambda (conn req)
-             (next-dispatcher))])
-        (lambda (conn req)
-          (next-dispatcher))))
   
-  ; gen-log-message : sym str -> str str sym url str -> str
+  (define (log-format->format log-format)
-  ; XXX: check apache log configuration formats
+    (case log-format
-  ; other server's include the original request line,
+      [(parenthesized-default)
-  ; including the major and minor HTTP version numbers
+       paren-format]
-  ; to produce a string that is displayed into the log file
+      [(extended)
-  ; This is a kill-safe wait-less abstraction
+       extended-format]
-  (define (gen-log-message log-format log-path)
+      [(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
+                   (display (format-req req) the-log-p)
-                    (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)
                    the-log-p))])))))))
     (lambda args
       (thread-resume log-thread (current-custodian))

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
+@defthing[format-req/c contract?]{
-@defproc[(make [#:log-format log-format symbol? 'parenthesized-default]
+ Equivalent to @scheme[(request? . -> . string?)].
-               [#: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))].
 
- If @scheme[log-format] is @scheme['extended], then the log looks like: 
+@defthing[paren-format format-req/c]{
- @scheme[`((client-ip ,(request-client-ip req))
+ Formats a request by:
-           (host-ip ,(request-host-ip req))
+ @schemeblock[
-           (referer ,(or/c bytes? false/c))                                              
+  (format "~s~n"
-           (uri ,(url->string (request-uri req)))
+            (list 'from (request-client-ip req)
-           (time ,(current-seconds)))].
+                  '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].
 }
                       
 @; ------------------------------------------------------------

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)