Changeset 12150 in project
- Timestamp:
- 10/13/08 21:19:26 (12 years ago)
- Location:
- release/4/spiffy/trunk
- Files:
-
- 2 edited
-
spiffy.scm (modified) (7 diffs)
-
ssp-handler.scm (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
release/4/spiffy/trunk/spiffy.scm
r12136 r12150 41 41 server-software root-path server-port index-files mime-type-map 42 42 default-mime-type file-extension-handlers default-host vhost-map 43 handle-directory handle-not-found 43 handle-directory handle-not-found handle-exception 44 44 restart-request htmlize) 45 45 … … 101 101 (lambda (path) 102 102 (send-status 404 "Not found" 103 "The resource you requested could not be found")))) 103 "<p>The resource you requested could not be found</p>")))) 104 (define handle-exception 105 (make-parameter 106 (lambda (exn chain) 107 (send-status 500 "Internal server error" (build-error-message exn chain))))) 108 109 (define build-error-message 110 (let* ((cpa condition-property-accessor) 111 (exn-message (cpa 'exn 'message "(no message)")) 112 (exn-location (cpa 'exn 'location "(unknown location)")) 113 (exn-arguments (cpa 'exn 'arguments '())) 114 (exn? (condition-predicate 'exn))) 115 (lambda (exn chain) 116 (with-output-to-string 117 (lambda () 118 (if (exn? exn) 119 (begin 120 (display "<h2>Error:") 121 (and-let* ((loc (exn-location exn))) 122 (printf " (<em>~A</em>)" (htmlize (->string loc)))) 123 (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn))) 124 (unless (null? (exn-arguments exn)) 125 (printf "<ul>") 126 (for-each 127 (lambda (a) 128 (##sys#with-print-length-limit 120 (lambda () (printf "<li>~S</li>" (htmlize (->string a)))))) 129 (exn-arguments exn)) 130 (printf "</ul>")) 131 (printf "<pre>~a</pre>" (htmlize chain))) 132 (begin 133 (##sys#with-print-length-limit 134 120 135 (lambda () 136 (printf "<h2>Uncaught exception:</h2>\n~S" exn)))))))))) 104 137 105 138 ;;; Internal parameters … … 128 161 (print " <body>") 129 162 (printf " <h1>~A - ~A</h1>\n" code reason) 130 (if text ( printf " <p>~A</p>"text))163 (if text (display text)) 131 164 (print " </body>") 132 165 (print "</html>"))))) … … 137 170 (lambda () 138 171 (write-response (current-response)) 139 (let ( [fd (file-open path (+ open/binary open/rdonly))])172 (let ((fd (file-open path (+ open/binary open/rdonly)))) 140 173 (handle-exceptions exn (begin 141 174 (file-close fd) … … 184 217 ((file-exists? path) 185 218 (parameterize ((current-pathinfo remaining-path) 186 (current-file path))187 ((handle-file) ( make-pathname "/" current-path))))219 (current-file (make-pathname "/" current-path))) 220 ((handle-file) (current-file)))) ;; hmm, not too useful 188 221 (else ((handle-not-found) (list "/" current-path)))))) 189 222 … … 230 263 (parameterize ((current-request req) 231 264 (request-restarter cont)) 232 (if (and (uri-host (request-uri (current-request))) (pair? path)) 233 (let* ((host (uri-host (request-uri (current-request)))) 234 (handler (alist-ref host 235 (vhost-map) 236 (lambda (h _) 237 (if (not (regexp? h)) 238 (string-match (regexp h #t) host) 239 (string-match h host)))))) 240 (if handler 241 (handler (lambda () (process-entry "" path))) 242 ;; Is this ok? 243 (send-status 404 "Not found" "Host not found"))) 244 ;; No host in the request? That's an error. 245 (send-status 400 "Bad request" 246 "Your client sent a request that the server did not understand")))) 265 (handle-exceptions exn ((handle-exception) exn 266 (with-output-to-string print-call-chain)) 267 (if (and (uri-host (request-uri (current-request))) (pair? path)) 268 (let* ((host (uri-host (request-uri (current-request)))) 269 (handler (alist-ref host 270 (vhost-map) 271 (lambda (h _) 272 (if (not (regexp? h)) 273 (string-match (regexp h #t) host) 274 (string-match h host)))))) 275 (if handler 276 (handler (lambda () (process-entry "" path))) 277 ;; Is this ok? 278 (send-status 404 "Not found" "<p>Host not found</p>"))) 279 ;; No host in the request? That's an error. 280 (send-status 400 "Bad request" 281 "<p>Your client sent a request that the server did not understand</p>"))))) 247 282 ;; For now, just close the ports and allow the thread to exit 248 283 (close-output-port out) … … 250 285 251 286 (define (htmlize str) 252 (string-translate* str '(("<" . "<") 253 (">" . ">") 254 ("\"" . """) 255 ("&" . "&")))) 287 (string-translate* str '(("<" . "<") (">" . ">") 288 ("\"" . """) ("&" . "&")))) 256 289 257 290 (define (start-server #!key (port (server-port))) 258 (letrec ((listener (tcp-listen port)) 259 (accept-loop (lambda () 260 (receive (in out) 261 (tcp-accept listener) 262 (thread-start! 263 (make-thread (lambda () 264 (handle-incoming-request in out)))) 265 (accept-loop))))) 266 (accept-loop))) 291 (parameterize ((load-verbose #f)) 292 (letrec ((listener (tcp-listen port)) 293 (accept-loop (lambda () 294 (receive (in out) 295 (tcp-accept listener) 296 (thread-start! 297 (make-thread (lambda () 298 (handle-incoming-request in out)))) 299 (accept-loop))))) 300 (accept-loop)))) 267 301 268 302 ) -
release/4/spiffy/trunk/ssp-handler.scm
r12135 r12150 119 119 (call/cc 120 120 (lambda (return) 121 (parameterize ( #;(load-verbose #f)121 (parameterize ((load-verbose #f) 122 122 (exit-handler (lambda _ (return #f)))) 123 123 (load filename (cut eval <> (ssp-eval-environment)))))))
Note: See TracChangeset
for help on using the changeset viewer.
