Changeset 12527 in project for release/4/spiffy/trunk/spiffy.scm

Timestamp:

11/16/08 15:28:06 (12 years ago)

Author:

sjamaan

Message:

Add logging support

File:

• release/4/spiffy/trunk/spiffy.scm (modified) (7 diffs)

release/4/spiffy/trunk/spiffy.scm

@@ -37 +37 @@
 
 (module spiffy
-  (start-server with-headers send-status send-static-file
+  (start-server with-headers send-status send-static-file log-to
+   write-logged-response
    current-request remote-address local-address
    current-response current-file current-pathinfo
    server-software root-path server-port index-files mime-type-map
    default-mime-type file-extension-handlers default-host vhost-map
-   handle-directory handle-not-found handle-exception
+   access-log error-log debug-log
+   handle-directory handle-not-found handle-exception handle-access-logging
    restart-request htmlize)
 
@@ -85 +87 @@
 (define default-host (make-parameter "localhost")) ;; XXX Can we do without?
 (define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
+(define access-log (make-parameter #f))
+(define error-log (make-parameter (current-error-port)))
+(define debug-log (make-parameter #f))
 
 ;;; Custom handlers
@@ -107 +112 @@
    (lambda (exn chain)
      (send-status 500 "Internal server error" (build-error-message exn chain)))))
+
+;; This is very powerful, but it also means people need to write quite
+;; a bit of code to change the line slightly. In this respect Apache-style
+;; log format strings could be better...
+(define handle-access-logging
+  (make-parameter
+   (lambda ()
+     (log-to (access-log)
+             "~A [~A] \"~A ~A HTTP/~A.~A\" ~A"
+             (remote-address)
+             (seconds->string (current-seconds))
+             (request-method (current-request))
+             (uri->string (request-uri (current-request)))
+             (request-major (current-request))
+             (request-minor (current-request))
+             (let ((product (header-contents 'user-agent
+                                             (request-headers (current-request)))))
+               (if product
+                   (product-unparser 'user-agent product)
+                   "**Unknown product**"))))))
+
+;;;; End of configuration parameters
+
+(define (with-output-to-log log thunk)
+  (when log
+    (if (output-port? log)
+        (with-output-to-port log thunk)
+        (with-output-to-file log thunk append:))))
+
+(define (log-to log fmt . rest)
+  (with-output-to-log log
+    (lambda ()
+      (apply printf fmt rest)
+      (newline))))
 
 (define build-error-message
@@ -137 +176 @@
                    (printf "<h2>Uncaught exception:</h2>\n~S" exn))))))))))
 
-;;; Internal parameters
-(define request-restarter (make-parameter #f))
-
 (define (extension->mime-type ext)
   (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
+
+(define (write-logged-response)
+  ((handle-access-logging))
+  (write-response (current-response)))
 
 ;; A simple utility procedure to render a status code with message
@@ -153 +193 @@
                                     `((content-type text/html))
                                     (response-headers (current-response))))))
-    (write-response (current-response))
+    (write-logged-response)
     (with-output-to-port (response-port (current-response))
       (lambda ()
@@ -176 +216 @@
                     (content-type ,(extension->mime-type (pathname-extension filename))))
       (lambda ()
-        (write-response (current-response))
+        (write-logged-response)
         (let ((fd (file-open path (+ open/binary open/rdonly))))
           (handle-exceptions exn (begin
@@ -255 +295 @@
                               (absolute-uri (conc "http://" host ":" port))))
         (current-request))))
+
+(define request-restarter (make-parameter #f)) ; Internal parameter
 
 (define (restart-request req)