Changeset 13206 in project

02/07/09 18:25:07 (12 years ago)

Update spiffy redirect handling so it generates an absolute URI (but does not change the request uri itself) and add a test for this. Refactor testlib a bit

3 edited


  • release/4/spiffy/trunk/spiffy.scm

    r13136 r13206  
    4343   current-request remote-address local-address
    4444   current-response current-file current-pathinfo
    45    server-software root-path server-port index-files mime-type-map
    46    default-mime-type file-extension-handlers default-host vhost-map
    47    access-log error-log debug-log spiffy-user spiffy-group access-file
     45   server-software root-path server-port server-root-uri index-files
     46   mime-type-map default-mime-type file-extension-handlers
     47   default-host vhost-map access-log error-log debug-log
     48   spiffy-user spiffy-group access-file
    4849   handle-file handle-directory handle-not-found handle-exception
    4950   handle-access-logging restart-request htmlize)
    273274(define (redirect-directory-root path)
    274275  (let ((new-path (uri-path (uri-reference (string-append path "/")))))
    275    (with-headers `((location ,(update-uri (request-uri (current-request))
     276   (with-headers `((location ,(update-uri (server-root-uri)
    276277                                          path: new-path)))
    277278     (lambda () (send-status 301 "Moved permanently")))))
    318319;; RFC 2616.  If no host line is present, it returns the default host
    319320;; for HTTP/1.0.
    320 (define (determine-vhost/port)
     321(define (determine-vhost)
    321322  (let* ((request-uri (request-uri (current-request)))
    322          (request-host (uri-host request-uri))
    323323         (host-header (header-value 'host (request-headers (current-request)))))
    324     (if request-host
    325         (values request-host (server-port))
    326         (if host-header
    327             (values (car host-header) (cdr host-header))
    328             (if (and (= (request-major (current-request)) 1)
    329                      (>= (request-minor (current-request)) 1))
    330                 (values #f #f)
    331                 (values (default-host) (server-port)))))))
    333 (define (normalize-current-request-uri)
    334   (receive (vhost vport)
    335     (determine-vhost/port)
    336     (let* ((uri (request-uri (current-request)))
    337            (host (or vhost (uri-host uri)))
    338            (port (or vport (uri-port uri) (server-port)))
    339            (scheme (or (uri-scheme uri) 'http))) ; XXX
    340       (update-request (current-request)
    341                       uri: (update-uri uri scheme: scheme host: host port: port)))))
     324    (if (and (= (request-major (current-request)) 1)
     325             (>= (request-minor (current-request)) 1)
     326             (not host-header))
     327        #f
     328        (or (uri-host request-uri)
     329            (if host-header
     330                (car host-header)
     331                (default-host))))))
     333(define (server-root-uri)
     334  (let ((uri (request-uri (current-request))))
     335    (if (uri-host uri) ; use absolute-uri? here
     336        uri
     337        (let ((host (determine-vhost))
     338              (scheme 'http) ; find out the scheme from port if https is allowed
     339              (port (server-port)))
     340          (update-uri uri scheme: scheme port: port host: host)))))
    343342(define request-restarter (make-parameter #f)) ; Internal parameter
    360359                                                (server ,(server-software)))))))
    361360       (receive (req cont)
    362          (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
     361         (call/cc (lambda (c) (values (current-request) c)))
    363362         (parameterize ((current-request req)
    364363                        (request-restarter cont))
    366365            exn ((handle-exception) exn
    367366                 (with-output-to-string print-call-chain))
    368             (let ((path (uri-path (request-uri (current-request)))))
    369               (if (and (uri-host (request-uri (current-request))) (pair? path)
    370                        (eq? (car path) '/))
    371                   (let* ((host (uri-host (request-uri (current-request))))
    372                          (handler (alist-ref host (vhost-map)
    373                                              (lambda (h _)
    374                                                (if (not (regexp? h))
    375                                                    (string-match (regexp h #t) host)
    376                                                    (string-match h host))))))
     367            (let ((path (uri-path (request-uri req)))
     368                  (host (determine-vhost)))
     369              (if (and host
     370                       (pair? path) ;; XXX change this to absolute-path?
     371                       (eq? (car path) '/))
     372                  (let ((handler
     373                         (alist-ref host (vhost-map)
     374                                    (lambda (h _)
     375                                      (if (not (regexp? h))
     376                                          (string-match (regexp h #t) host)
     377                                          (string-match h host))))))
    377378                    (if handler
    378379                        (handler (lambda () (process-entry "" "" (cdr path))))
    379380                        ;; Is this ok?
    380381                        ((handle-not-found) path)))
    381                   ;; No host in the request? That's an error.
     382                  ;; No host or a relative URI in the request? That's an error.
    382383                  (send-status 400 "Bad request"
    383384                               "<p>Your client sent a request that the server did not understand</p>"))))))
  • release/4/spiffy/trunk/tests/run.scm

    r13136 r13206  
    3939(test "Regexp case sensitivity" `(404 ,NOT-FOUND) (fetch-file "hello.txt" "TESTHOST"))
    4040(test "Nonexistent host name" `(404 ,NOT-FOUND) (fetch-file "hello.txt" ""))
     41(test "No host on HTTP/1.0 works" `(200 ,hello.txt) (fetch-file "hello.txt" "foohost" send-headers: '()))
     42(test "No host on HTTP/1.1 gives error" 400 (car (fetch-file "hello.txt" "foohost" send-headers: '() version: '(1 1))))
    4143(test-end "vhost support")
    4951(test-begin "static file serving")
    5052(test "Nonexistant file" `(404 ,NOT-FOUND) (fetch-file "bogus" "testhost"))
    51 (test "Nonexistant file mimetype" 'text/html (header-value 'content-type (get-headers "bogus" "testhost")))
     53(test "Nonexistant file mimetype" 'text/html (header-value 'content-type (fetch-file "bogus" "testhost" get-headers: #t)))
    5254(test "Nonexistant file with extension" `(404 ,NOT-FOUND) (fetch-file "bogus.gif" "testhost"))
    53 (test "Nonexistant file with extension mimetype" 'text/html (header-value 'content-type (get-headers "bogus.gif" "testhost")))
    54 (test "text/plain mimetype" 'text/plain (header-value 'content-type (get-headers "hello.txt" "testhost")))
    55 (test "image/gif mimetype" 'image/gif (header-value 'content-type (get-headers "pics/lambda-chicken.gif" "testhost")))
     55(test "Nonexistant file with extension mimetype" 'text/html (header-value 'content-type (fetch-file "bogus.gif" "testhost" get-headers: #t)))
     56(test "text/plain mimetype" 'text/plain (header-value 'content-type (fetch-file "hello.txt" "testhost" get-headers: #t)))
     57(test "image/gif mimetype" 'image/gif (header-value 'content-type (fetch-file "pics/lambda-chicken.gif" "testhost" get-headers: #t)))
    5658(test "image/gif contents" `(200 ,lambda-chicken.gif) (fetch-file "pics/lambda-chicken.gif" "testhost"))
    57 (test "image/png mimetype" 'image/png (header-value 'content-type (get-headers "pics/chicken-logo.png" "testhost")))
     59(test "image/png mimetype" 'image/png (header-value 'content-type (fetch-file "pics/chicken-logo.png" "testhost" get-headers: #t)))
    5860(test "image/png contents" `(200 ,chicken-logo.png)  (fetch-file "pics/chicken-logo.png" "testhost"))
    59 (test "unknown mimetype" 'application/unknown (header-value 'content-type (get-headers "data" "testhost")))
     61(test "unknown mimetype" 'application/unknown (header-value 'content-type (fetch-file "data" "testhost" get-headers: #t)))
     62(test "'Moved Permanently' on directory" 301 (car (fetch-file "pics" "testhost")))
     63(test "location URI is absolute" "http://testhost:8080/pics/"
     64      (uri->string (header-value 'location (fetch-file "pics" "testhost" get-headers: #t absolute-uri: #f))))
    6065(test "directory listing denied" `(403 ,"forbidden") (fetch-file "pics/" "testhost"))
    6166(test-end "static file serving")
    6368(test-begin "path normalization")
    64 (test "index page redir" '(/ "subdir" "") (uri-path (header-value 'location (get-headers "/subdir" "testhost"))))
    65 (test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (get-headers "/subdir?foo=bar" "testhost"))))
     69(test "index page redir" '(/ "subdir" "") (uri-path (header-value 'location (fetch-file "/subdir" "testhost" get-headers: #t))))
     70(test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (fetch-file "/subdir?foo=bar" "testhost" get-headers: #t))))
    6671(test "index page redir status" 301 (car (fetch-file "/subdir" "testhost")))
    6772(test "index page" `(200 ,index-subdir) (fetch-file "/subdir/" "testhost"))
    6873(test "break out of webroot fails" `(200 ,index-subdir) (fetch-file "/subdir/../../subdir/" "testhost"))
    6974(test "index page in subdir vhost" `(200 ,index-subdir) (fetch-file "/" "subdir-host"))
    70 (test "index page redir for subdir vhost" '(/ "subsubdir" "") (uri-path (header-value 'location (get-headers "/subsubdir" "subdir-host"))))
     75(test "index page redir for subdir vhost" '(/ "subsubdir" "") (uri-path (header-value 'location (fetch-file "/subsubdir" "subdir-host" get-headers: #t))))
    7176(test "index page redir status for subdir vhost" `301 (car (fetch-file "/subsubdir" "subdir-host")))
    7277(test "index page in subdir for subdir vhost" `(200 ,index-subsubdir) (fetch-file "/subsubdir/" "subdir-host"))
    8893(test-begin "miscellaneous")
    8994(test "redirect" 303 (car (fetch-file "blah" "redirect-host")))
    90 (test "redirect location" (uri-reference "/move-along") (header-value 'location (get-headers "blah" "redirect-host")))
     95(test "redirect location" (uri-reference "/move-along") (header-value 'location (fetch-file "blah" "redirect-host" get-headers: #t)))
    9196(test "internal error" `(500 ,EXN) (fetch-file "cause-error" "error-host"))
    9297(test-end "miscellaneous")
  • release/4/spiffy/trunk/tests/testlib.scm

    r13054 r13206  
    5757;;;; test tools
    59 (define (fetch-file file host)
    60   (let ((uri (uri-reference (sprintf "http://~A:~A/~A" host (server-port) file))))
     59(define (fetch-file file host #!key (send-headers `((host: ,host))) (get-headers #f) (version '(1 0)) (absolute-uri #t))
     60  (let ((uri (uri-reference (if absolute-uri
     61                                (sprintf "http://~A:~A/~A" host (server-port) file)
     62                                (sprintf "/~A" file)))))
    6163    (receive (in out)
    62       (tcp-connect "" (uri-port uri))
    63       (let* ((req-headers (headers `((host: ,(uri-host uri)))))
    64              (req (make-request method: 'GET uri: uri major: 1 minor: 0
     64      (tcp-connect "" (server-port))
     65      (let* ((req-headers (headers send-headers))
     66             (req (make-request method: 'GET uri: uri
     67                                major: (car version) minor: (cadr version)
    6568                                headers: req-headers port: out)))
    6669        (write-request req)
    6972          (close-output-port out)
    7073          (close-input-port in)
    71           (list (response-code resp) str))))))
    73 (define (get-headers file host)
    74   (let ((uri (uri-reference (sprintf "http://~A:~A/~A" host (server-port) file))))
    75     (receive (in out)
    76       (tcp-connect "" (uri-port uri))
    77       (let* ((req-headers (headers `((host: ,(uri-host uri)))))
    78              (req (make-request method: 'GET uri: uri major: 1 minor: 0
    79                                 headers: req-headers port: out)))
    80         (write-request req)
    81         (let* ((resp (read-response in))
    82                (str (read-string (header-value 'content-length (response-headers resp)) in)))
    83           (close-output-port out)
    84           (close-input-port in)
    85           (response-headers resp))))))
     74          (if get-headers
     75              (response-headers resp)
     76              (list (response-code resp) str)))))))
Note: See TracChangeset for help on using the changeset viewer.