Changeset 12527 in project


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

Add logging support

Location:
release/4/spiffy/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/cgi-handler.scm

    r12511 r12527  
    132132                                           (string-join (uri-path (request-uri req)) "/"))))
    133133         (env (cgi-build-env req path)))
    134     ;; TODO: stderr should be linked to spiffy error log (make log first)
     134    ;; TODO: stderr should be linked to spiffy error log
    135135    (if (file-execute-access? interp)
    136136        ;; XXX The script should be called with the query args on the
     
    139139        ;; XXX Current working directory should be the dir with the script.
    140140        (let-values (((i o pid) (process interp '() env)))
    141           #;(log "(cgi) started program ~a(~a) ..." interp fn)
     141          (log-to (debug-log) "(cgi) started program ~a(~a) ..." interp fn)
    142142          (copy-port (request-port (current-request)) o len)
    143143          (close-output-port o)
     
    163163                                             code: code
    164164                                             reason: reason)))
    165               (write-response (current-response))
     165              (write-logged-response)
    166166              (copy-port i (response-port (current-response)))
    167167              (close-input-port i))))
  • release/4/spiffy/trunk/simple-directory-handler.scm

    r12135 r12527  
    8989                    (content-length ,(string-length str)))
    9090      (lambda ()
    91        (write-response (current-response))
     91       (write-logged-response)
    9292       (display str (response-port (current-response)))))))
    9393)
  • 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)
  • release/4/spiffy/trunk/ssp-handler.scm

    r12520 r12527  
    3535(module ssp-handler
    3636  (ssp-handler ssp-include ssp-stringize ssp-short-open-tag ssp-long-open-tag
    37    ssp-close-tag ssp-eval-environment current-workdir exit-handler)
     37   ssp-close-tag ssp-eval-environment current-workdir ssp-exit-handler)
    3838
    3939(import chicken scheme spiffy extras ports regex files posix)
     
    4141
    4242(define current-workdir (make-parameter #f))
    43 (define exit-handler    (make-parameter #f))
     43(define ssp-exit-handler    (make-parameter #f))
    4444
    4545(define ssp-eval-environment (make-parameter (interaction-environment)))
     
    5050                  (content-length ,(string-length out)))
    5151    (lambda ()
    52       (write-response (current-response))
     52      (write-logged-response)
    5353      (display out (response-port (current-response)))))))
    5454
     
    121121   (lambda (return)
    122122     (parameterize ((load-verbose #f)
    123                     (exit-handler (lambda _ (return #f))))
     123                    (ssp-exit-handler (lambda _ (return #f))))
    124124       (load filename (cut eval <> (ssp-eval-environment)))))))
    125125
  • release/4/spiffy/trunk/web-scheme-handler.scm

    r12135 r12527  
    6363                    (content-length ,(string-length out)))
    6464      (lambda ()
    65        (write-response (current-response))
     65       (write-logged-response)
    6666       (display out (response-port (current-response)))))))
    6767
Note: See TracChangeset for help on using the changeset viewer.