Changeset 10536 in project


Ignore:
Timestamp:
04/19/08 14:33:51 (12 years ago)
Author:
sjamaan
Message:

Implement redirect on directory request without trailing slash, and write tests for that. Also implement proper normalization of paths

Location:
release/3/spiffy/trunk
Files:
3 added
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/spiffy/trunk/spiffy-base.scm

    r9976 r10536  
    6363(define current-response-headers (make-parameter '()))
    6464(define current-response-code (make-parameter '(200 . "OK")))
    65 (define current-workdir (make-parameter "."))  ;; XXX MOVEME
     65(define current-workdir (make-parameter "/"))
    6666(define current-pathinfo (make-parameter #f))
    6767(define current-path (make-parameter #f))
     
    225225  (send-static-file fn))
    226226
    227 (define (chop-slash fn)
    228   (let ([len (sub1 (string-length fn))])
    229     (if (and (> len 0) (char=? #\/ (string-ref fn len)))
    230         (substring fn 0 len)
    231         fn) ) )
    232 
    233227(http:fallback-handler
    234228 (let ((old (http:fallback-handler)))
    235229   (spiffy-not-found-handler (lambda () (old (current-request)))) ;; Slightly ugly, but needed so toplevel config can redefine it
    236230   (lambda (req)
     231     
    237232     (parameterize ((current-request req)
    238233                    (current-response-code '(200 . "OK"))
     
    243238              ((spiffy-exception-handler) exn))
    244239         (dispatch-vhost old))))))
     240
     241(define (normalize-path path)
     242  (let loop ((parts (string-split path "/"))
     243             (result '()))
     244    (cond
     245     ((null? parts) (string-join (reverse result) "/" 'prefix))
     246     ((string=? (car parts) "..")
     247      (if (null? result)
     248          (loop (cdr parts) result)
     249          (loop (cdr parts) (cdr result))))
     250     ((string=? (car parts) ".")
     251      (loop (cdr parts) result))
     252     (else (loop (cdr parts) (cons (car parts) result))))))
    245253
    246254(define (dispatch-vhost old)
     
    257265                     (current-path path))
    258266        (if handler
    259             (handler (lambda () (handle-entry (spiffy-root-path) path)))
     267            (handler (lambda () (handle-entry (current-workdir) (normalize-path path))))
    260268            (begin
    261269              (log-error "No match for vhost ~A" host)
     
    263271
    264272(define (split-dir str)
    265   (let* ((cleaned (string-trim-both str #\/))
    266          (idx (string-index cleaned #\/)))
     273  (let ((idx (string-index str #\/)))
    267274    (if idx
    268         (values (string-take cleaned idx) (string-drop cleaned (add1 idx)))
    269         (values cleaned #f))))
    270 
    271 (define (apply-access-file current-path remaining-path continue)
    272   (let ((access-file (make-pathname current-path (spiffy-access-file))))
     275        (values (string-take str idx) (string-drop str (add1 idx)))
     276        (values str #f))))
     277
     278(define (apply-access-file path remaining-path continue)
     279  (let ((access-file (make-pathname path (spiffy-access-file))))
    273280    (if (and (spiffy-access-file) (file-exists? access-file))
    274281        ((eval (call-with-input-file access-file read)) continue)
     
    277284(define (handle-entry incomplete-path remaining-path)
    278285  (receive (file rest) (split-dir remaining-path)
    279     (let ((path (make-pathname incomplete-path file)))
     286    (let ((path (make-pathname (make-pathname (spiffy-root-path) incomplete-path) file)))
    280287      (cond
    281288       (((spiffy-access-denied?) incomplete-path file) (http:write-error-response 403 "Forbidden"))
     
    283290        (apply-access-file path rest
    284291                           (lambda ()
    285                              (if rest
    286                                  (handle-entry path rest)
    287                                  (let ((index-page (find (lambda (ip)
    288                                                            (file-exists? (make-pathname path ip)))
    289                                                          (spiffy-index-pages))))
    290                                    (if index-page
    291                                        (handle-entry path index-page)
    292                                        ((spiffy-handle-directory) (chop-slash path))))))))
     292                             (cond
     293                               ((not rest)
     294                                (if (and (not (string-null? (current-path))) (string=? (string-take-right (current-path) 1) "/"))
     295                                    (let ((index-page (find (lambda (ip)
     296                                                              (file-exists? (make-pathname path ip)))
     297                                                            (spiffy-index-pages))))
     298                                      (if index-page
     299                                          (handle-entry (make-pathname incomplete-path file) index-page)
     300                                          ((spiffy-handle-directory) path)))
     301                                    (moved-permanently (string-append (make-pathname incomplete-path file) "/"))))
     302                               (else (handle-entry (make-pathname incomplete-path file) rest))))))
    293303       ((file-exists? path)
    294304        (let* ((ext (or (pathname-extension path) ""))
     
    420430  (write-fragment-response (sprintf "<html><head><title>Moved</title><body><h1>Moved</h1>Please see <a href=\"~A\">~A</a>.</body></html>" loc loc)))
    421431
     432(define (moved-permanently loc)
     433  (current-response-code '(301 . "Moved Permanently"))
     434  (set-header! (sprintf "Location: ~A" loc))
     435  (write-fragment-response (sprintf "<html><head><title>Moved permanently</title><body><h1>Moved permanently</h1>Please see <a href=\"~A\">~A</a>.</body></html>" loc loc)))
     436
    422437(define (redirect loc)
    423438  (current-response-code '(302 . "Found"))
     
    495510
    496511(define (load-once filename)
    497   (let* ([fn (make-pathname (current-workdir) filename)]
     512  (let* ([fn (make-pathname (make-pathname (spiffy-root-path) (current-workdir) filename))]
    498513         [a (assoc fn loaded-files)]
    499514         [tm (file-modification-time fn)])
  • release/3/spiffy/trunk/tests/spiffy-base-test.scm

    r10337 r10536  
    66
    77(define noway "No way, Jose!")
     8
     9(define counter 0)
    810
    911(test-begin "setup")
     
    5557(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-string))
    5658(define index.html (with-input-from-file "testweb/index.html" read-string))
     59(define index-subdir (with-input-from-file "testweb/subdir/index.html" read-string))
    5760
    5861(test-begin "static file serving")
     
    6770(test "image/png contents" `(200 ,chicken-logo.png)  (fetch-file "pics/chicken-logo.png" "testhost"))
    6871(test "unknown mimetype" "application/unknown" (header-ref "content-type" (get-headers "data" "testhost")))
    69 (test "directory listing denied" `(403 ,ERROR) (fetch-file "pics" "testhost"))
    70 (test "index page" `(200 ,index.html) (fetch-file "" "testhost"))
     72(test "directory listing denied" `(403 ,ERROR) (fetch-file "pics/" "testhost"))
     73(test "index page redir" "/subdir/" (header-ref "location" (get-headers "/subdir" "testhost")))
     74(test "index page redir status" `(301 "<html><head><title>Moved permanently</title><body><h1>Moved permanently</h1>Please see <a href=\"/subdir/\">/subdir/</a>.</body></html>") (fetch-file "/subdir" "testhost"))
     75(test "index page" `(200 ,index-subdir) (fetch-file "/subdir/" "testhost"))
    7176(test "HTTP 1.1" `(200 ,index.html) (fetch-file "index.html" "testhost" 'HTTP/1.1))
    7277(test "HTTP 1.1 404" `(404 ,ERROR) (fetch-file "bogus" "testhost" 'HTTP/1.1))
     
    7479
    7580(test-begin "access files")
     81(set! counter 0)
     82(test "Two slashes" `(200 ,index-subdir) (fetch-file "subdir//" "testhost"))
     83(test "After two slashes, counter is 1" `(1) `(,counter))
    7684(test "Dir request" `(200 ,noway) (fetch-file "secrets" "testhost")) ;; Access file applies on dir and all below
    7785(test "File request in dir" `(200 ,noway) (fetch-file "secrets/password.txt" "testhost"))
Note: See TracChangeset for help on using the changeset viewer.