make an abstraction for dispatch-{log,logresp}

Author: sorawee

web-server-lib/web-server/dispatchers/dispatch-log.rkt

@@ -3,13 +3,12 @@
 (require net/url
          racket/contract
          racket/date
-         racket/path
          (prefix-in srfi-date: srfi/19)
          web-server/dispatchers/dispatch
-         web-server/http)
+         web-server/http
+         "private/log.rkt")
 
 (define format-req/c (request? . -> . string?))
-(define log-format/c (symbols 'parenthesized-default 'extended 'apache-default))
 
 (provide/contract
  [format-req/c contract?]
@@ -25,6 +24,7 @@
             dispatcher/c)])
 
 (define interface-version 'v1)
+
 (define (make #:format [format paren-format]
               #:log-path [log-path "log"])
   (define final-format
@@ -50,94 +50,36 @@
           (string-upcase (bytes->string/utf-8 (request-method req)))
           (url->string (request-uri req))))
 
-(define (apache-default-format req)
+(define (apache-default-format/obj req)
   (define request-time (srfi-date:current-date))
-  (format "~a - - [~a] \"~a\" ~a ~a\n"
-          (request-client-ip req)
-          (srfi-date:date->string request-time "~d/~b/~Y:~T ~z")
-          (request-line-raw req)
-          "-"
-          "-"))
+  (list (request-client-ip req)
+        (srfi-date:date->string request-time "~d/~b/~Y:~T ~z")
+        (request-line-raw req)))
+
+(define apache-default-format
+  (make-format "~a - - [~a] \"~a\" - -\n" apache-default-format/obj))
+
+(define (paren-format/obj req)
+  (list (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 (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 paren-format (make-format "~s\n" paren-format/obj))
 
-(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 (extended-format/obj req)
+  `(((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-or-port format-req)
-  (define path (if (output-port? log-path-or-port) #f log-path-or-port))
-  (define dir-path (and path (simple-form-path (build-path path 'up))))
-  (define (make-dir-change-evt)
-    (if dir-path (filesystem-change-evt dir-path) never-evt))
-  (define (open-output-port)
-    (cond
-      [path
-       (define out (open-output-file path #:exists 'append))
-       (begin0 out
-         (file-stream-buffer-mode out 'line))]
-      [else
-       log-path-or-port]))
-  (define log-ch (make-channel))
-  (define log-thread
-    (thread/suspend-to-kill
-     (lambda ()
-       (let loop ([log-p #f]
-                  [dir-evt (make-dir-change-evt)])
-         (sync
-          (handle-evt
-           dir-evt
-           (lambda (_)
-             (define-values (the-log-p the-dir-evt)
-               (with-handlers ([exn:fail?
-                                (lambda (e)
-                                  ((error-display-handler) "dispatch-log.rkt Error watching filesystem" e)
-                                  (close-output-port/safe log-p)
-                                  (values #f never-evt))])
-                 ;; Something in the directory changed ...
-                 (cond
-                   [(not log-p)
-                    ;; ... but we haven't opened the file yet.
-                    (values #f (make-dir-change-evt))]
-                   [(file-exists? path)
-                    ;; ... but our target file is intact.
-                    (values log-p (make-dir-change-evt))]
-                   [else
-                    ;; ... and the file has been rotated, so open a new port.
-                    (close-output-port/safe log-p)
-                    (values (open-output-port) (make-dir-change-evt))])))
-             (loop the-log-p the-dir-evt)))
-          (handle-evt
-           log-ch
-           (lambda (req)
-             (define the-log-p
-               (with-handlers ([exn:fail?
-                                 (lambda (e)
-                                   ((error-display-handler) "dispatch-log.rkt Error writing log entry" e)
-                                   (close-output-port/safe log-p)
-                                   (loop #f dir-evt))])
-                 (define the-log-p
-                   (or log-p (open-output-port)))
-                 (begin0 the-log-p
-                   (display (format-req req) the-log-p))))
-             (loop the-log-p dir-evt))))))))
-  (lambda (req)
-    (thread-resume log-thread (current-custodian))
-    (channel-put log-ch req)))
+(define extended-format (make-format "~s\n" extended-format/obj))
 
-(define (close-output-port/safe p)
-  (when p
-    (with-handlers ([exn:fail? void])
-      (close-output-port p))))
+(module+ private
+  (provide apache-default-format/obj
+           paren-format/obj
+           extended-format/obj))

web-server-lib/web-server/dispatchers/dispatch-logresp.rkt

@@ -1,17 +1,15 @@
 #lang racket/base
-(require net/url
-         (prefix-in srfi-date: srfi/19)
-         racket/date
-         racket/async-channel
-         racket/match
-         racket/contract)
-(require web-server/dispatchers/dispatch
+
+(require racket/contract
+         web-server/dispatchers/dispatch
          web-server/http
-         web-server/http/response)
+         web-server/http/response
+         "private/log.rkt"
+         (submod web-server/dispatchers/dispatch-log private))
+
 (define format-reqresp/c
   (or/c (-> request? string?)
         (-> request? response? string?)))
-(define log-format/c (symbols 'parenthesized-default 'extended 'apache-default))
 
 (provide/contract
  [format-reqresp/c contract?]
@@ -26,19 +24,27 @@
              #:log-path (or/c path-string? output-port?))
             dispatcher/c)])
 
+(define interface-version 'v1)
+
 (define ((log-header-handler log-message req original-handler) resp)
-  (log-message req resp)
-  (original-handler resp))
+  (define new-resp (original-handler resp))
+  (log-message req new-resp)
+  new-resp)
 
-(define interface-version 'v1)
 (define (make #:format [format paren-format]
               #:log-path [log-path "log"]
               dispatcher)
   (define final-format
     (if (symbol? format)
         (log-format->format format)
         format))
-  (define log-message (make-log-message log-path final-format))
+  (define log-message (make-log-message
+                       log-path
+                       (λ (req resp)
+                         (cond
+                           [(procedure-arity-includes? final-format 2)
+                            (final-format req resp)]
+                           [else (final-format req)]))))
   (lambda (conn req)
     (with-handlers ([exn:dispatcher? (lambda (e) (next-dispatcher))])
       (parameterize ([current-header-handler (log-header-handler log-message req (current-header-handler))])
@@ -53,75 +59,20 @@
     [(apache-default)
      apache-default-format]))
 
-(define (request-line-raw req)
-  (format "~a ~a HTTP/1.1"
-          (string-upcase (bytes->string/utf-8 (request-method req)))
-          (url->string (request-uri req))))
-(define (apache-default-format req resp)
-  (define request-time (srfi-date:current-date))
-  (format "~a - - [~a] \"~a\" ~a ~a\n"
-          (request-client-ip req)
-          (srfi-date:date->string request-time "~d/~b/~Y:~T ~z")
-          (request-line-raw req)
-          (response-code resp)
-          "-"))
-
-(define (paren-format req resp)
-  (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)
-                'code (response-code resp))))
+(define apache-default-format
+  (make-format "~a - - [~a] \"~a\" ~a -\n"
+               (λ (req resp)
+                 (append (apache-default-format/obj req)
+                         (list (response-code resp))))))
 
-(define (extended-format req resp)
-  (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))
-            (code ,(response-code resp)))))
+(define paren-format
+  (make-format "~s\n"
+               (λ (req resp)
+                 (list (append (car (paren-format/obj req))
+                               (list 'code (response-code resp)))))))
 
-(define (make-log-message log-path-or-port format-reqresp)
-  (define log-ch (make-async-channel))
-  (define log-thread
-    (thread/suspend-to-kill
-     (lambda ()
-       (let loop ([log-p #f])
-         (sync
-          (handle-evt
-           log-ch
-           (match-lambda
-             [(list req resp)
-              (loop
-               (with-handlers ([exn:fail? (lambda (e)
-                                            ((error-display-handler) "dispatch-logresp.rkt Error writing log entry" e)
-                                            (with-handlers ([exn:fail? (lambda (e) #f)])
-                                              (close-output-port log-p))
-                                            #f)])
-                 (define the-log-p
-                   (if (path-string? log-path-or-port)
-                       (if (not (and log-p (file-exists? log-path-or-port)))
-                           (begin
-                             (unless (eq? log-p #f)
-                               (close-output-port log-p))
-                             (let ([new-log-p (open-output-file log-path-or-port #:exists 'append)])
-                               (file-stream-buffer-mode new-log-p 'line)
-                               new-log-p))
-                           log-p)
-                       log-path-or-port))
-                 (display
-                  (cond
-                    [(procedure-arity-includes? format-reqresp 2)
-                     (format-reqresp req resp)]
-                    [else (format-reqresp req)])
-                  the-log-p)
-                 the-log-p))])))))))
-  (lambda args
-    (thread-resume log-thread (current-custodian))
-    (async-channel-put log-ch args)
-    (void)))
+(define extended-format
+  (make-format "~s\n"
+               (λ (req resp)
+                 (list (append (car (extended-format/obj req))
+                               (list (list 'code (response-code resp))))))))

web-server-lib/web-server/dispatchers/private/log.rkt

@@ -0,0 +1,81 @@
+#lang racket/base
+
+(provide make-log-message
+         make-format
+         log-format/c)
+
+(require racket/path
+         racket/contract)
+
+(define log-format/c (symbols 'parenthesized-default 'extended 'apache-default))
+
+(define (make-log-message log-path-or-port formatter)
+  (define path (if (output-port? log-path-or-port) #f log-path-or-port))
+  (define dir-path (and path (simple-form-path (build-path path 'up))))
+  (define (make-dir-change-evt)
+    (if dir-path (filesystem-change-evt dir-path) never-evt))
+  (define (open-output-port)
+    (cond
+      [path
+       (define out (open-output-file path #:exists 'append))
+       (begin0 out
+         (file-stream-buffer-mode out 'line))]
+      [else
+       log-path-or-port]))
+  (define log-ch (make-channel))
+  (define log-thread
+    (thread/suspend-to-kill
+     (lambda ()
+       (let loop ([log-p #f]
+                  [dir-evt (make-dir-change-evt)])
+         (sync
+          (handle-evt
+           dir-evt
+           (lambda (_)
+             (define-values (the-log-p the-dir-evt)
+               (with-handlers ([exn:fail?
+                                (lambda (e)
+                                  ((error-display-handler) "Error watching filesystem" e)
+                                  (close-output-port/safe log-p)
+                                  (values #f never-evt))])
+                 ;; Something in the directory changed ...
+                 (cond
+                   [(not log-p)
+                    ;; ... but we haven't opened the file yet.
+                    (values #f (make-dir-change-evt))]
+                   [(file-exists? path)
+                    ;; ... but our target file is intact.
+                    (values log-p (make-dir-change-evt))]
+                   [else
+                    ;; ... and the file has been rotated, so open a new port.
+                    (close-output-port/safe log-p)
+                    (values (open-output-port) (make-dir-change-evt))])))
+             (loop the-log-p the-dir-evt)))
+          (handle-evt
+           log-ch
+           (lambda (args)
+             (define the-log-p
+               (with-handlers ([exn:fail?
+                                 (lambda (e)
+                                   ((error-display-handler) "Error writing log entry" e)
+                                   (close-output-port/safe log-p)
+                                   (loop #f dir-evt))])
+                 (define the-log-p
+                   (or log-p (open-output-port)))
+                 (begin0 the-log-p
+                   (display (apply formatter args) the-log-p))))
+             (loop the-log-p dir-evt))))))))
+  (lambda args
+    (thread-resume log-thread (current-custodian))
+    (channel-put log-ch args)))
+
+(define (close-output-port/safe p)
+  (when p
+    (with-handlers ([exn:fail? void])
+      (close-output-port p))))
+
+(define (make-format fmt proc)
+  (define mask (procedure-arity-mask proc))
+  (procedure-reduce-arity-mask
+   (λ args (apply format fmt (apply proc args)))
+   mask))