Changeset 12022 in project

Timestamp:

09/28/08 17:27:05 (12 years ago)

Author:

sjamaan

Message:

Implement section 5.2 of RFC2616

File:

• release/4/spiffy/trunk/spiffy.scm (modified) (5 diffs)

release/4/spiffy/trunk/spiffy.scm

@@ -39 +39 @@
   (start-server with-headers send-status send-static-file
                 current-request current-response current-file current-pathinfo
-                current-hostname
                 root-path server-port index-files mime-type-map default-mime-type
+                default-host
                 handle-directory handle-not-found)
 
@@ -55 +55 @@
 (define current-file     (make-parameter #f))
 (define current-pathinfo (make-parameter #f))
-(define current-hostname (make-parameter #f))
 
 ;;; Configuration
@@ -78 +77 @@
      ("png" . image/png))))
 (define default-mime-type (make-parameter 'application/octet-stream))
+(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
 
 ;;; Custom handlers
@@ -176 +176 @@
      (else ((handle-not-found))))))
 
-;; Determine the vhost to use. This tries to use the Host: header first
-;; and if it's not there, falls back to try to determine the vhost
-;; from host in the request line's URI, if any.
-;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of RFC 2616.
-;; It returns the empty string for HTTP/1.0, which is a bit of a hack but
-;; makes host regex matching less complicated.
-(define (determine-vhost)
-  (let ((host/port (header-value 'host (request-headers (current-request)) #f)))
-    (if host/port
-        (car host/port)
-        (if (and (= (request-major (current-request)) 1)
-                 (>= (request-minor (current-request)) 1))
-            #f
-            (or (uri-host (request-uri (current-request))) "")))))
+;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
+;; If request URL is absolute, use that.  Otherwise, look at the Host header.
+;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
+;; RFC 2616.  If no host line is present, it returns the default host
+;; for HTTP/1.0.
+(define (determine-vhost/port)
+  (let* ((request-uri (request-uri (current-request)))
+         (request-host (uri-host request-uri))
+         (host-header (header-value 'host (request-headers (current-request)))))
+    (if request-host
+        (values request-host (or (uri-port request-uri) 80))
+        (if host-header
+            (values (car host-header) (cdr host-header))
+            (if (and (= (request-major (current-request)) 1)
+                     (>= (request-minor (current-request)) 1))
+                (values #f #f)
+                (values (default-host) 80))))))
+
+(define (normalize-current-request-uri)
+  (receive (host port) (determine-vhost/port)
+    (if host
+        (update-request (current-request)
+                        uri: (uri-relative-to
+                              (request-uri (current-request))
+                              ;; XXX
+                              (absolute-uri (conc "http://" host ":" port))))
+        (current-request))))
 
 (define (handle-incoming-request in out)
@@ -197 +210 @@
                                  headers: (headers
                                            `((content-type text/html))))))
-    (let* ((host (determine-vhost))
-           (path (uri-path (request-uri (current-request)))))
-      (if (and host (pair? path))
-          (parameterize ((current-hostname host)
-                         ;; Ensure the request URI includes host and scheme
-                         ;; Perhaps the intarweb egg should do this
-                         (current-request
-                          (update-request
-                           (current-request)
-                           uri: (uri-relative-to
-                                 (request-uri (current-request))
-                                 (absolute-uri (string-append "http://" host)))))) ; XXX
-            (process-entry "" path))
-          ;; No host in the request? That's an error.
-          (send-status 400 "Bad request"
-                       "Your client sent a request that the server did not understand"))
+    (let ((path (uri-path (request-uri (current-request)))))
+      (parameterize ((current-request (normalize-current-request-uri)))
+            (if (and (uri-host (request-uri (current-request))) (pair? path))
+                (process-entry "" path)
+                ;; No host in the request? That's an error.
+                (send-status 400 "Bad request"
+                             "Your client sent a request that the server did not understand")))
       ;; For now, just close the ports and allow the thread to exit
       (close-output-port out)