Changeset 13598 in project


Ignore:
Timestamp:
03/08/09 17:56:22 (11 years ago)
Author:
sjamaan
Message:

Implement request keepalive, and fix CGI code

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

Legend:

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

    r13030 r13598  
    3939
    4040(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)
    4242
    4343(define (cgi-handler* #!optional interp)
     
    4848         (conc (car entry) "=" (or (cdr entry) "")))
    4949       alist))
    50 
    51 (define (query->string q)
    52   (and q
    53       (string-join (map (lambda (entry)
    54                           (string-append (car entry) "=" (cdr entry))) q) "&")))
    5550
    5651(define (environmentize str)
     
    8378                                 (unparse-header 'content-type contents)))
    8479            ("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))))
    8681            ("REMOTE_ADDR" . ,(remote-address))
    8782            ;; This should really be the FQDN of the remote address
     
    126121             (loop (read-string (min (or limit bufsize) bufsize) in))))))
    127122
     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
    128132(define (status-parser str)
    129133  (let ((parts (string-match "([0-9]+) (.+)" str)))
     
    148152          (close-output-port o)
    149153          ;; TODO: Implement read timeout
    150           (let* ((new-headers (parameterize ((header-parsers
    151                                               (cons `(status
    152                                                      . ,(single status-parser))
    153                                                     (header-parsers))))
    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))
    157161                 (code (cond
    158162                        (status (car status))
     
    165169            (parameterize ((current-response
    166170                            (update-response (current-response)
    167                                              headers: new-headers
     171                                             headers:  (sanitize-headers
     172                                                        script-headers)
    168173                                             code: code
    169174                                             reason: reason)))
  • release/4/spiffy/trunk/spiffy.scm

    r13456 r13598  
    206206  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
    207207
     208(define handle-another-request? (make-parameter #f)) ;; Internal parameter
     209
    208210(define (write-logged-response)
    209211  ((handle-access-logging))
     212  (handle-another-request? (and (keep-alive? (current-request))
     213                                (keep-alive? (current-response))))
    210214  (write-response (current-response)))
    211215
    212216;; 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))))))
    239245
    240246(define (send-static-file filename)
     
    346352  ((request-restarter) req (request-restarter)))
    347353
    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)
    356360                    (current-response
    357361                     (make-response port: out
    358362                                    headers: (headers
    359363                                              `((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?))))))))
    389388
    390389(define (htmlize str)
     
    436435                      (thread-start!
    437436                       (lambda ()
     437                         ;; thread-count _must_ be updated, so trap all exns
    438438                         (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))))
    440455                         (mutex-update! thread-count sub1)))))
    441456                (accept-next-connection))))
Note: See TracChangeset for help on using the changeset viewer.