Changeset 13598 in project
- Timestamp:
- 03/08/09 17:56:22 (11 years ago)
- Location:
- release/4/spiffy/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/spiffy/trunk/cgi-handler.scm
r13030 r13598 39 39 40 40 (import chicken scheme extras files posix regex data-structures) 41 (require-extension spiffy srfi-1 srfi-13 intarweb uri- generic)41 (require-extension spiffy srfi-1 srfi-13 intarweb uri-common) 42 42 43 43 (define (cgi-handler* #!optional interp) … … 48 48 (conc (car entry) "=" (or (cdr entry) ""))) 49 49 alist)) 50 51 (define (query->string q)52 (and q53 (string-join (map (lambda (entry)54 (string-append (car entry) "=" (cdr entry))) q) "&")))55 50 56 51 (define (environmentize str) … … 83 78 (unparse-header 'content-type contents))) 84 79 ("PATH_INFO" . ,(string-join (current-pathinfo) "/")) 85 ("QUERY_STRING" . ,( query->string(uri-query (request-uri req))))80 ("QUERY_STRING" . ,(form-urlencode (uri-query (request-uri req)))) 86 81 ("REMOTE_ADDR" . ,(remote-address)) 87 82 ;; This should really be the FQDN of the remote address … … 126 121 (loop (read-string (min (or limit bufsize) bufsize) in)))))) 127 122 123 ;; "the server retains its responsibility to the client to conform to the 124 ;; relevant network protocol even if the CGI script fails to conform to 125 ;; this specification." -- RFC 3875, Section 3.1 126 ;; The simplest way to ensure that the client conforms to the protocol 127 ;; is to discard any content-length headers and simply close the connection. 128 (define (sanitize-headers script-headers) 129 (headers '((connection close)) 130 (remove-header 'content-length script-headers))) 131 128 132 (define (status-parser str) 129 133 (let ((parts (string-match "([0-9]+) (.+)" str))) … … 148 152 (close-output-port o) 149 153 ;; TODO: Implement read timeout 150 (let* (( new-headers (parameterize ((header-parsers151 (cons `(status152 153 154 (read-headers i)))155 (loc (header-value 'location new-headers))156 (status (header-value 'status new-headers))154 (let* ((script-headers (parameterize 155 ((header-parsers 156 `((status . ,(single status-parser)) 157 ,@(header-parsers)))) 158 (read-headers i))) 159 (loc (header-value 'location script-headers)) 160 (status (header-value 'status script-headers)) 157 161 (code (cond 158 162 (status (car status)) … … 165 169 (parameterize ((current-response 166 170 (update-response (current-response) 167 headers: new-headers 171 headers: (sanitize-headers 172 script-headers) 168 173 code: code 169 174 reason: reason))) -
release/4/spiffy/trunk/spiffy.scm
r13456 r13598 206 206 (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type))) 207 207 208 (define handle-another-request? (make-parameter #f)) ;; Internal parameter 209 208 210 (define (write-logged-response) 209 211 ((handle-access-logging)) 212 (handle-another-request? (and (keep-alive? (current-request)) 213 (keep-alive? (current-response)))) 210 214 (write-response (current-response))) 211 215 212 216 ;; A simple utility procedure to render a status code with message 213 (define (send-status code reason #!optional text) 214 (parameterize ((current-response 215 (update-response (current-response) 216 code: code 217 reason: reason 218 headers: 219 (headers 220 `((content-type text/html)) 221 (response-headers (current-response)))))) 222 (write-logged-response) 223 (with-output-to-port (response-port (current-response)) 224 (lambda () 225 (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>") 226 (print "<!DOCTYPE html") 227 (print " PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"") 228 (print " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") 229 (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ") 230 (print " xml:lang=\"en\" lang=\"en\">") 231 (print " <head>") 232 (printf " <title>~A - ~A</title>\n" code reason) 233 (print " </head>") 234 (print " <body>") 235 (printf " <h1>~A - ~A</h1>\n" code reason) 236 (if text (display text)) 237 (print " </body>") 238 (print "</html>"))))) 217 (define (send-status code reason #!optional (text "")) 218 (let* ((htmlized-reason (htmlize reason)) 219 (output 220 (conc "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>\n" 221 "<!DOCTYPE html\n" 222 " PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" 223 " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" 224 "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n" 225 " xml:lang=\"en\" lang=\"en\">\n" 226 " <head>\n" 227 " <title>" code " - " htmlized-reason "</title>\n" 228 " </head>\n" 229 " <body>\n" 230 " <h1>" code " - " htmlized-reason "</h1>\n" 231 text "\n" ; *not* htmlized, so this can contain HTML 232 " </body>\n" 233 "</html>\n"))) 234 (parameterize ((current-response 235 (update-response (current-response) 236 code: code 237 reason: reason 238 headers: 239 (headers 240 `((content-type text/html) 241 (content-length ,(string-length output))) 242 (response-headers (current-response)))))) 243 (write-logged-response) 244 (display output (response-port (current-response)))))) 239 245 240 246 (define (send-static-file filename) … … 346 352 ((request-restarter) req (request-restarter))) 347 353 348 (define (handle-incoming-request in out) 349 (receive (local remote) 350 (tcp-addresses in) 351 (handle-exceptions ; XXX FIXME; this should be more fine-grained 352 exn (fprintf out "Invalid request") 353 (parameterize ((remote-address remote) 354 (local-address local) 355 (current-request (read-request in)) 354 (define (handle-incoming-request in out keep-going) 355 (handle-exceptions ; This should probably be more fine-grained 356 exn (fprintf out "Invalid request\r\n") 357 (receive (req cont) 358 (call/cc (lambda (c) (values (read-request in) c))) 359 (parameterize ((current-request req) 356 360 (current-response 357 361 (make-response port: out 358 362 headers: (headers 359 363 `((content-type text/html) 360 (server ,(server-software))))))) 361 (receive (req cont) 362 (call/cc (lambda (c) (values (current-request) c))) 363 (parameterize ((current-request req) 364 (request-restarter cont)) 365 (handle-exceptions 366 exn ((handle-exception) exn 367 (with-output-to-string print-call-chain)) 368 (let ((path (uri-path (request-uri req))) 369 (host (determine-vhost))) 370 (if (and host 371 (pair? path) ;; XXX change this to absolute-path? 372 (eq? (car path) '/)) 373 (let ((handler 374 (alist-ref host (vhost-map) 375 (lambda (h _) 376 (if (not (regexp? h)) 377 (string-match (regexp h #t) host) 378 (string-match h host)))))) 379 (if handler 380 (handler (lambda () (process-entry "" "" (cdr path)))) 381 ;; Is this ok? 382 ((handle-not-found) path))) 383 ;; No host or non-absolute URI in the request is an error. 384 (send-status 400 "Bad request" 385 "<p>Your client sent a request that the server did not understand</p>")))))) 386 ;; For now, just close the ports and allow the thread to exit 387 (close-output-port out) 388 (close-input-port in))))) 364 (server ,(server-software)))))) 365 (request-restarter cont)) 366 (handle-exceptions 367 exn ((handle-exception) exn 368 (with-output-to-string print-call-chain)) 369 (let ((path (uri-path (request-uri req))) 370 (host (determine-vhost))) 371 (if (and host 372 (pair? path) ;; XXX change this to absolute-path? 373 (eq? (car path) '/)) 374 (let ((handler 375 (alist-ref host (vhost-map) 376 (lambda (h _) 377 (if (not (regexp? h)) 378 (string-match (regexp h #t) host) 379 (string-match h host)))))) 380 (if handler 381 (handler (lambda () (process-entry "" "" (cdr path)))) 382 ;; Is this ok? 383 ((handle-not-found) path))) 384 ;; No host or non-absolute URI in the request is an error. 385 (send-status 400 "Bad request" 386 "<p>Your client sent a request that the server did not understand</p>")) 387 (keep-going (handle-another-request?)))))))) 389 388 390 389 (define (htmlize str) … … 436 435 (thread-start! 437 436 (lambda () 437 ;; thread-count _must_ be updated, so trap all exns 438 438 (handle-exceptions 439 e #f (handle-incoming-request in out)) 439 e (void) 440 (receive (local remote) 441 (tcp-addresses in) 442 ;; This won't change during the session 443 (parameterize ((remote-address remote) 444 (local-address local) 445 (handle-another-request? #t)) 446 (let handle-next-request () 447 ;; This is needed to unwind all PARAMETERIZEs 448 (when (call/cc 449 (lambda (k) 450 (handle-incoming-request in out k) 451 #f)) ; in case of errors, we get here 452 (handle-next-request))) 453 (close-input-port in) 454 (close-output-port out)))) 440 455 (mutex-update! thread-count sub1))))) 441 456 (accept-next-connection))))
Note: See TracChangeset
for help on using the changeset viewer.