Changeset 13598 in project

Timestamp:

03/08/09 17:56:22 (12 years ago)

Author:

sjamaan

Message:

Implement request keepalive, and fix CGI code

Location:

release/4/spiffy/trunk

Files:

• cgi-handler.scm (modified) (6 diffs)
• spiffy.scm (modified) (3 diffs)

release/4/spiffy/trunk/cgi-handler.scm

@@ -39 +39 @@
 
 (import chicken scheme extras files posix regex data-structures)
-(require-extension spiffy srfi-1 srfi-13 intarweb uri-generic)
+(require-extension spiffy srfi-1 srfi-13 intarweb uri-common)
 
 (define (cgi-handler* #!optional interp)
@@ -48 +48 @@
          (conc (car entry) "=" (or (cdr entry) "")))
        alist))
-
-(define (query->string q)
-  (and q
-      (string-join (map (lambda (entry)
-                          (string-append (car entry) "=" (cdr entry))) q) "&")))
 
 (define (environmentize str)
@@ -83 +78 @@
                                  (unparse-header 'content-type contents)))
             ("PATH_INFO" . ,(string-join (current-pathinfo) "/"))
-            ("QUERY_STRING" . ,(query->string (uri-query (request-uri req))))
+            ("QUERY_STRING" . ,(form-urlencode (uri-query (request-uri req))))
             ("REMOTE_ADDR" . ,(remote-address))
             ;; This should really be the FQDN of the remote address
@@ -126 +121 @@
              (loop (read-string (min (or limit bufsize) bufsize) in))))))
 
+;; "the server retains its responsibility to the client to conform to the
+;;  relevant network protocol even if the CGI script fails to conform to
+;;  this specification." -- RFC 3875, Section 3.1
+;; The simplest way to ensure that the client conforms to the protocol
+;; is to discard any content-length headers and simply close the connection.
+(define (sanitize-headers script-headers)
+  (headers '((connection close))
+           (remove-header 'content-length script-headers)))
+
 (define (status-parser str)
   (let ((parts (string-match "([0-9]+) (.+)" str)))
@@ -148 +152 @@
           (close-output-port o)
           ;; TODO: Implement read timeout
-          (let* ((new-headers (parameterize ((header-parsers
-                                              (cons `(status
-                                                      . ,(single status-parser))
-                                                    (header-parsers))))
-                                (read-headers i)))
-                 (loc (header-value 'location new-headers))
-                 (status (header-value 'status new-headers))
+          (let* ((script-headers (parameterize
+                                     ((header-parsers
+                                       `((status . ,(single status-parser))
+                                         ,@(header-parsers))))
+                                   (read-headers i)))
+                 (loc (header-value 'location script-headers))
+                 (status (header-value 'status script-headers))
                  (code (cond
                         (status (car status))
@@ -165 +169 @@
             (parameterize ((current-response
                             (update-response (current-response)
-                                             headers: new-headers
+                                             headers:  (sanitize-headers
+                                                        script-headers)
                                              code: code
                                              reason: reason)))

release/4/spiffy/trunk/spiffy.scm

@@ -206 +206 @@
   (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
 
+(define handle-another-request? (make-parameter #f)) ;; Internal parameter
+
 (define (write-logged-response)
   ((handle-access-logging))
+  (handle-another-request? (and (keep-alive? (current-request))
+                                (keep-alive? (current-response))))
   (write-response (current-response)))
 
 ;; A simple utility procedure to render a status code with message
-(define (send-status code reason #!optional text)
-  (parameterize ((current-response
-                  (update-response (current-response)
-                                   code: code
-                                   reason: reason
-                                   headers:
-                                   (headers
-                                    `((content-type text/html))
-                                    (response-headers (current-response))))))
-    (write-logged-response)
-    (with-output-to-port (response-port (current-response))
-      (lambda ()
-        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
-        (print "<!DOCTYPE html")
-        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
-        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
-        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
-        (print "      xml:lang=\"en\" lang=\"en\">")
-        (print "  <head>")
-        (printf "    <title>~A - ~A</title>\n" code reason)
-        (print "  </head>")
-        (print "  <body>")
-        (printf "    <h1>~A - ~A</h1>\n" code reason)
-        (if text (display text))
-        (print "  </body>")
-        (print "</html>")))))
+(define (send-status code reason #!optional (text ""))
+  (let* ((htmlized-reason (htmlize reason))
+         (output 
+          (conc "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>\n"
+                "<!DOCTYPE html\n"
+                "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"
+                "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
+                "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n"
+                "      xml:lang=\"en\" lang=\"en\">\n"
+                "  <head>\n"
+                "    <title>" code " - " htmlized-reason "</title>\n"
+                "  </head>\n"
+                "  <body>\n"
+                "    <h1>" code " - " htmlized-reason "</h1>\n"
+                text "\n"         ; *not* htmlized, so this can contain HTML
+                "  </body>\n"
+                "</html>\n")))
+   (parameterize ((current-response
+                   (update-response (current-response)
+                                    code: code
+                                    reason: reason
+                                    headers:
+                                    (headers
+                                     `((content-type text/html)
+                                       (content-length ,(string-length output)))
+                                     (response-headers (current-response))))))
+     (write-logged-response)
+     (display output (response-port (current-response))))))
 
 (define (send-static-file filename)
@@ -346 +352 @@
   ((request-restarter) req (request-restarter)))
 
-(define (handle-incoming-request in out)
-  (receive (local remote)
-    (tcp-addresses in)
-    (handle-exceptions ; XXX FIXME; this should be more fine-grained
-     exn (fprintf out "Invalid request")
-     (parameterize ((remote-address remote)
-                    (local-address local)
-                    (current-request (read-request in))
+(define (handle-incoming-request in out keep-going)
+  (handle-exceptions       ; This should probably be more fine-grained
+   exn (fprintf out "Invalid request\r\n")
+   (receive (req cont)
+     (call/cc (lambda (c) (values (read-request in) c)))
+     (parameterize ((current-request req)
                     (current-response
                      (make-response port: out
                                     headers: (headers
                                               `((content-type text/html)
-                                                (server ,(server-software)))))))
-       (receive (req cont)
-         (call/cc (lambda (c) (values (current-request) c)))
-         (parameterize ((current-request req)
-                        (request-restarter cont))
-           (handle-exceptions
-            exn ((handle-exception) exn
-                 (with-output-to-string print-call-chain))
-            (let ((path (uri-path (request-uri req)))
-                  (host (determine-vhost)))
-              (if (and host
-                       (pair? path) ;; XXX change this to absolute-path?
-                       (eq? (car path) '/))
-                  (let ((handler
-                         (alist-ref host (vhost-map)
-                                    (lambda (h _)
-                                      (if (not (regexp? h))
-                                          (string-match (regexp h #t) host)
-                                          (string-match h host))))))
-                    (if handler
-                        (handler (lambda () (process-entry "" "" (cdr path))))
-                        ;; Is this ok?
-                        ((handle-not-found) path)))
-                  ;; No host or non-absolute URI in the request is an error.
-                  (send-status 400 "Bad request"
-                               "<p>Your client sent a request that the server did not understand</p>"))))))
-       ;; For now, just close the ports and allow the thread to exit
-       (close-output-port out)
-       (close-input-port in)))))
+                                                (server ,(server-software))))))
+                    (request-restarter cont))
+       (handle-exceptions
+        exn ((handle-exception) exn
+             (with-output-to-string print-call-chain))
+        (let ((path (uri-path (request-uri req)))
+              (host (determine-vhost)))
+          (if (and host
+                   (pair? path) ;; XXX change this to absolute-path?
+                   (eq? (car path) '/))
+              (let ((handler
+                     (alist-ref host (vhost-map)
+                                (lambda (h _)
+                                  (if (not (regexp? h))
+                                      (string-match (regexp h #t) host)
+                                      (string-match h host))))))
+                (if handler
+                    (handler (lambda () (process-entry "" "" (cdr path))))
+                    ;; Is this ok?
+                    ((handle-not-found) path)))
+              ;; No host or non-absolute URI in the request is an error.
+              (send-status 400 "Bad request"
+                           "<p>Your client sent a request that the server did not understand</p>"))
+          (keep-going (handle-another-request?))))))))
 
 (define (htmlize str)
@@ -436 +435 @@
                       (thread-start!
                        (lambda ()
+                         ;; thread-count _must_ be updated, so trap all exns
                          (handle-exceptions
-                          e #f (handle-incoming-request in out))
+                          e (void)
+                          (receive (local remote)
+                            (tcp-addresses in)
+                            ;; This won't change during the session
+                            (parameterize ((remote-address remote)
+                                           (local-address local)
+                                           (handle-another-request? #t))
+                              (let handle-next-request ()
+                                ;; This is needed to unwind all PARAMETERIZEs
+                                (when (call/cc
+                                       (lambda (k)
+                                         (handle-incoming-request in out k)
+                                         #f)) ; in case of errors, we get here
+                                  (handle-next-request)))
+                              (close-input-port in)
+                              (close-output-port out))))
                          (mutex-update! thread-count sub1)))))
                 (accept-next-connection))))