Changeset 12527 in project for release/4/spiffy/trunk/spiffy.scm
- Timestamp:
- 11/16/08 15:28:06 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/spiffy/trunk/spiffy.scm
r12478 r12527 37 37 38 38 (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 40 41 current-request remote-address local-address 41 42 current-response current-file current-pathinfo 42 43 server-software root-path server-port index-files mime-type-map 43 44 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 45 47 restart-request htmlize) 46 48 … … 85 87 (define default-host (make-parameter "localhost")) ;; XXX Can we do without? 86 88 (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)) 87 92 88 93 ;;; Custom handlers … … 107 112 (lambda (exn chain) 108 113 (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)))) 109 148 110 149 (define build-error-message … … 137 176 (printf "<h2>Uncaught exception:</h2>\n~S" exn)))))))))) 138 177 139 ;;; Internal parameters140 (define request-restarter (make-parameter #f))141 142 178 (define (extension->mime-type ext) 143 179 (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))) 144 184 145 185 ;; A simple utility procedure to render a status code with message … … 153 193 `((content-type text/html)) 154 194 (response-headers (current-response)))))) 155 (write- response (current-response))195 (write-logged-response) 156 196 (with-output-to-port (response-port (current-response)) 157 197 (lambda () … … 176 216 (content-type ,(extension->mime-type (pathname-extension filename)))) 177 217 (lambda () 178 (write- response (current-response))218 (write-logged-response) 179 219 (let ((fd (file-open path (+ open/binary open/rdonly)))) 180 220 (handle-exceptions exn (begin … … 255 295 (absolute-uri (conc "http://" host ":" port)))) 256 296 (current-request)))) 297 298 (define request-restarter (make-parameter #f)) ; Internal parameter 257 299 258 300 (define (restart-request req)
Note: See TracChangeset
for help on using the changeset viewer.