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


Ignore:
Timestamp:
11/16/08 15:28:06 (12 years ago)
Author:
sjamaan
Message:

Add logging support

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/spiffy.scm

    r12478 r12527  
    3737
    3838(module spiffy
    39   (start-server with-headers send-status send-static-file
     39  (start-server with-headers send-status send-static-file log-to
     40   write-logged-response
    4041   current-request remote-address local-address
    4142   current-response current-file current-pathinfo
    4243   server-software root-path server-port index-files mime-type-map
    4344   default-mime-type file-extension-handlers default-host vhost-map
    44    handle-directory handle-not-found handle-exception
     45   access-log error-log debug-log
     46   handle-directory handle-not-found handle-exception handle-access-logging
    4547   restart-request htmlize)
    4648
     
    8587(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
    8688(define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
     89(define access-log (make-parameter #f))
     90(define error-log (make-parameter (current-error-port)))
     91(define debug-log (make-parameter #f))
    8792
    8893;;; Custom handlers
     
    107112   (lambda (exn chain)
    108113     (send-status 500 "Internal server error" (build-error-message exn chain)))))
     114
     115;; This is very powerful, but it also means people need to write quite
     116;; a bit of code to change the line slightly. In this respect Apache-style
     117;; log format strings could be better...
     118(define handle-access-logging
     119  (make-parameter
     120   (lambda ()
     121     (log-to (access-log)
     122             "~A [~A] \"~A ~A HTTP/~A.~A\" ~A"
     123             (remote-address)
     124             (seconds->string (current-seconds))
     125             (request-method (current-request))
     126             (uri->string (request-uri (current-request)))
     127             (request-major (current-request))
     128             (request-minor (current-request))
     129             (let ((product (header-contents 'user-agent
     130                                             (request-headers (current-request)))))
     131               (if product
     132                   (product-unparser 'user-agent product)
     133                   "**Unknown product**"))))))
     134
     135;;;; End of configuration parameters
     136
     137(define (with-output-to-log log thunk)
     138  (when log
     139    (if (output-port? log)
     140        (with-output-to-port log thunk)
     141        (with-output-to-file log thunk append:))))
     142
     143(define (log-to log fmt . rest)
     144  (with-output-to-log log
     145    (lambda ()
     146      (apply printf fmt rest)
     147      (newline))))
    109148
    110149(define build-error-message
     
    137176                   (printf "<h2>Uncaught exception:</h2>\n~S" exn))))))))))
    138177
    139 ;;; Internal parameters
    140 (define request-restarter (make-parameter #f))
    141 
    142178(define (extension->mime-type ext)
    143179  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
     180
     181(define (write-logged-response)
     182  ((handle-access-logging))
     183  (write-response (current-response)))
    144184
    145185;; A simple utility procedure to render a status code with message
     
    153193                                    `((content-type text/html))
    154194                                    (response-headers (current-response))))))
    155     (write-response (current-response))
     195    (write-logged-response)
    156196    (with-output-to-port (response-port (current-response))
    157197      (lambda ()
     
    176216                    (content-type ,(extension->mime-type (pathname-extension filename))))
    177217      (lambda ()
    178         (write-response (current-response))
     218        (write-logged-response)
    179219        (let ((fd (file-open path (+ open/binary open/rdonly))))
    180220          (handle-exceptions exn (begin
     
    255295                              (absolute-uri (conc "http://" host ":" port))))
    256296        (current-request))))
     297
     298(define request-restarter (make-parameter #f)) ; Internal parameter
    257299
    258300(define (restart-request req)
Note: See TracChangeset for help on using the changeset viewer.