Changeset 12022 in project


Ignore:
Timestamp:
09/28/08 17:27:05 (12 years ago)
Author:
sjamaan
Message:

Implement section 5.2 of RFC2616

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/spiffy.scm

    r12005 r12022  
    3939  (start-server with-headers send-status send-static-file
    4040                current-request current-response current-file current-pathinfo
    41                 current-hostname
    4241                root-path server-port index-files mime-type-map default-mime-type
     42                default-host
    4343                handle-directory handle-not-found)
    4444
     
    5555(define current-file     (make-parameter #f))
    5656(define current-pathinfo (make-parameter #f))
    57 (define current-hostname (make-parameter #f))
    5857
    5958;;; Configuration
     
    7877     ("png" . image/png))))
    7978(define default-mime-type (make-parameter 'application/octet-stream))
     79(define default-host (make-parameter "localhost")) ;; XXX Can we do without?
    8080
    8181;;; Custom handlers
     
    176176     (else ((handle-not-found))))))
    177177
    178 ;; Determine the vhost to use. This tries to use the Host: header first
    179 ;; and if it's not there, falls back to try to determine the vhost
    180 ;; from host in the request line's URI, if any.
    181 ;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of RFC 2616.
    182 ;; It returns the empty string for HTTP/1.0, which is a bit of a hack but
    183 ;; makes host regex matching less complicated.
    184 (define (determine-vhost)
    185   (let ((host/port (header-value 'host (request-headers (current-request)) #f)))
    186     (if host/port
    187         (car host/port)
    188         (if (and (= (request-major (current-request)) 1)
    189                  (>= (request-minor (current-request)) 1))
    190             #f
    191             (or (uri-host (request-uri (current-request))) "")))))
     178;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
     179;; If request URL is absolute, use that.  Otherwise, look at the Host header.
     180;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
     181;; RFC 2616.  If no host line is present, it returns the default host
     182;; for HTTP/1.0.
     183(define (determine-vhost/port)
     184  (let* ((request-uri (request-uri (current-request)))
     185         (request-host (uri-host request-uri))
     186         (host-header (header-value 'host (request-headers (current-request)))))
     187    (if request-host
     188        (values request-host (or (uri-port request-uri) 80))
     189        (if host-header
     190            (values (car host-header) (cdr host-header))
     191            (if (and (= (request-major (current-request)) 1)
     192                     (>= (request-minor (current-request)) 1))
     193                (values #f #f)
     194                (values (default-host) 80))))))
     195
     196(define (normalize-current-request-uri)
     197  (receive (host port) (determine-vhost/port)
     198    (if host
     199        (update-request (current-request)
     200                        uri: (uri-relative-to
     201                              (request-uri (current-request))
     202                              ;; XXX
     203                              (absolute-uri (conc "http://" host ":" port))))
     204        (current-request))))
    192205
    193206(define (handle-incoming-request in out)
     
    197210                                 headers: (headers
    198211                                           `((content-type text/html))))))
    199     (let* ((host (determine-vhost))
    200            (path (uri-path (request-uri (current-request)))))
    201       (if (and host (pair? path))
    202           (parameterize ((current-hostname host)
    203                          ;; Ensure the request URI includes host and scheme
    204                          ;; Perhaps the intarweb egg should do this
    205                          (current-request
    206                           (update-request
    207                            (current-request)
    208                            uri: (uri-relative-to
    209                                  (request-uri (current-request))
    210                                  (absolute-uri (string-append "http://" host)))))) ; XXX
    211             (process-entry "" path))
    212           ;; No host in the request? That's an error.
    213           (send-status 400 "Bad request"
    214                        "Your client sent a request that the server did not understand"))
     212    (let ((path (uri-path (request-uri (current-request)))))
     213      (parameterize ((current-request (normalize-current-request-uri)))
     214            (if (and (uri-host (request-uri (current-request))) (pair? path))
     215                (process-entry "" path)
     216                ;; No host in the request? That's an error.
     217                (send-status 400 "Bad request"
     218                             "Your client sent a request that the server did not understand")))
    215219      ;; For now, just close the ports and allow the thread to exit
    216220      (close-output-port out)
Note: See TracChangeset for help on using the changeset viewer.