diff --git a/collects/tests/web-server/dispatchers/filesystem-map-test.rkt b/collects/tests/web-server/dispatchers/filesystem-map-test.rkt index 49f6f5c3bb..f3ed284718 100644 --- a/collects/tests/web-server/dispatchers/filesystem-map-test.rkt +++ b/collects/tests/web-server/dispatchers/filesystem-map-test.rkt @@ -6,6 +6,10 @@ web-server/dispatchers/filesystem-map) (provide filesystem-map-tests) +(module+ test + (require rackunit/text-ui) + (run-tests filesystem-map-tests)) + (define-runtime-path base-dir "../../../web-server") @@ -38,9 +42,8 @@ (test-case "Strips parameters" (test-url->path test-map (build-path "dispatchers/filesystem-map.rkt") #:url-string "http://test.com/dispatchers/filesystem-map.rkt;foo")) - (test-case "Strips outs bad '..'s" - (test-url->path test-map (build-path "dispatchers/filesystem-map.rkt") - #:url-string "http://test.com/../../dispatchers/filesystem-map.rkt")) + (test-case "Strips out bad '..'s" + (check-exn exn:fail? (λ () (test-map (string->url "http://test.com/../../dispatchers/filesystem-map.rkt"))))) (test-case "Leaves in good '..'s" (test-url->path test-map (build-path "dispatchers/../dispatchers/filesystem-map.rkt")))) @@ -53,9 +56,8 @@ (test-case "Strips parameters" (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.rkt") #:url-string "http://test.com/dispatchers/filesystem-map.rkt;foo")) - (test-case "Strips outs bad '..'s" - (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.rkt") - #:url-string "http://test.com/../../dispatchers/filesystem-map.rkt")) + (test-case "Strips out bad '..'s" + (check-exn exn:fail? (λ () (test-valid-map (string->url "http://test.com/../../dispatchers/filesystem-map.rkt"))))) (test-case "Leaves in good '..'s" (test-url->path test-valid-map (build-path "dispatchers/../dispatchers/filesystem-map.rkt")))) (test-case "Finds valid path underneath" @@ -82,3 +84,4 @@ (test-case "Allows content after w/ valid" (test-url->path test-filter-valid-map (build-path "dispatchers/filesystem-map.rkt/extra/info") #:expected (build-path "dispatchers/filesystem-map.rkt")))))) + diff --git a/collects/tests/web-server/private/util-test.rkt b/collects/tests/web-server/private/util-test.rkt index 397a44bf18..65ff0d42a7 100644 --- a/collects/tests/web-server/private/util-test.rkt +++ b/collects/tests/web-server/private/util-test.rkt @@ -63,21 +63,6 @@ "Not prefix" (check-false (list-prefix? '(a b c) '(b c d))))) - (test-suite - "strip-prefix-ups" - (test-case - "Does not apply" - (check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path "bar")))) - (build-path "bar"))) - (test-case - "Applies no suffix" - (check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path 'up 'up 'up "bar")))) - (build-path "bar"))) - (test-case - "Applies with suffix" - (check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path 'up 'up 'up "bar" "foo")))) - (build-path "bar" "foo")))) - (test-suite "url-path->string" (test-case diff --git a/collects/web-server/dispatchers/filesystem-map.rkt b/collects/web-server/dispatchers/filesystem-map.rkt index 0f5b1a0fed..f016053e8f 100644 --- a/collects/web-server/dispatchers/filesystem-map.rkt +++ b/collects/web-server/dispatchers/filesystem-map.rkt @@ -1,6 +1,7 @@ #lang racket/base (require net/url racket/list + racket/match racket/contract) (require web-server/private/util) (define url->path/c @@ -12,6 +13,56 @@ [make-url->valid-path (url->path/c . -> . url->path/c)] [filter-url->path (regexp? url->path/c . -> . url->path/c)]) +(define (restrict l) + (not + (negative? + (let loop ([end-in-file? #f] [depth 0] [l l]) + (match l + [(list) + (if end-in-file? + (sub1 depth) + depth)] + [(list-rest (or ".." 'up) rst) + (loop #f (sub1 depth) rst)] + [(list-rest (or "" 'same) rst) + (loop #f depth rst)] + [(list-rest _ rst) + (loop #t (add1 depth) rst)]))))) + +(module+ test + (require rackunit) + + (check-equal? (restrict (list)) + #t) + (check-equal? (restrict (list 'up)) + #f) + (check-equal? (restrict (list "..")) + #f) + (check-equal? (restrict (list 'same)) + #t) + (check-equal? (restrict (list 'same "..")) + #f) + + (check-equal? (restrict (list "foo" 'up "bar")) + #t) + (check-equal? (restrict (list "foo" 'up 'up "bar")) + #f) + (check-equal? (restrict (list 'up "bar")) + #f) + (check-equal? (restrict (list "foo" "bar" 'up "bar")) + #t) + (check-equal? (restrict (list "foo" "bar" 'up 'up 'up "bar")) + #f) + + (check-equal? (restrict (list "foo" 'same "bar" 'up 'up 'up "bar")) + #f) + (check-equal? (restrict (list "foo" "" "bar" 'up 'up 'up "bar")) + #f) + (check-equal? (restrict (list "foo" "bar" 'up "bar" 'same)) + #t) + (check-equal? (restrict (list "foo" "bar" 'up "bar" "")) + #t)) + (define (build-path* . l) (if (empty? l) (build-path 'same) @@ -19,23 +70,18 @@ (define ((make-url->path base) u) (define nbase (path->complete-path base)) + (define path-from-url + (map path/param-path + (url-path u))) + (unless (restrict path-from-url) + (error 'url->path "Illegal path: ~e outside base: ~e" + path-from-url + base)) (define the-path - ; Complete it against the base (path->complete-path - ; Build a path - (apply build-path* - ; Remove all ".."s - (strip-prefix-ups - (map (lambda (p) - (if (and (string? p) (string=? "" p)) - 'same - p)) - ; Extract the paths from the url-path - (map path/param-path - (url-path u))))) + (apply build-path* path-from-url) nbase)) (define w/o-base (path-without-base nbase the-path)) - #;(printf "~S\n" `(url->path ,base ,nbase ,(url->string u) ,the-path ,w/o-base)) (values the-path w/o-base)) (define ((make-url->valid-path url->path) u) diff --git a/collects/web-server/private/util.rkt b/collects/web-server/private/util.rkt index 1d563653ae..a383c4cbc2 100644 --- a/collects/web-server/private/util.rkt +++ b/collects/web-server/private/util.rkt @@ -61,30 +61,6 @@ ;; Eli: We already have `explode-path', this looks like it's doing the ;; same thing, except a little less useful. -; strip-prefix-ups : (listof path-piece?) -> (listof path-piece?) -(define (strip-prefix-ups l) - (define prefix? (box #t)) - (filter (lambda (p) - (if (unbox prefix?) - (if (eq? 'up p) - #f - (begin #t - (set-box! prefix? #f))) - #t)) - l)) -;; Eli: This is bad. If I understand it correctly, this is what this -;; *should* have been: -;; (define (strip-prefix-ups l) -;; (if (and (pair? l) (eq? 'up (car l))) (strip-prefix-ups (cdr l)) l)) -;; or even: -;; (define (strip-prefix-ups l) -;; (match l [(cons 'up l) (strip-prefix-ups l)] [_ l])) -;; except that the above version manages to combine ugly and -;; obfuscated code, redundant mutation, redundant code (why is it a -;; box? why is there a (begin #t ...)?), and being extra slow. Oh, -;; and if this wasn't enough, there's exactly one place in the web -;; server that uses it. - ; path-without-base : path? path? -> (listof path-piece?) (define (path-without-base base path) (define b (explode-path* base)) @@ -120,7 +96,6 @@ (provide/contract [explode-path* (path-string? . -> . (listof path-piece?))] [path-without-base (path-string? path-string? . -> . (listof path-piece?))] - [strip-prefix-ups ((listof path-piece?) . -> . (listof path-piece?))] [directory-part (path-string? . -> . path?)] [build-path-unless-absolute (path-string? path-string? . -> . path?)]) diff --git a/collects/web-server/scribblings/misc-util.scrbl b/collects/web-server/scribblings/misc-util.scrbl index 17bdec3a45..e8d04dc6ca 100644 --- a/collects/web-server/scribblings/misc-util.scrbl +++ b/collects/web-server/scribblings/misc-util.scrbl @@ -48,11 +48,6 @@ Prepends @racket[base] to @racket[p], unless @racket[p] is absolute. } -@defproc[(strip-prefix-ups [p (listof path-piece?)]) - (listof path-piece?)]{ - Removes all the prefix @racket[".."]s from @racket[p]. -} - @defproc[(network-error [s symbol?] [fmt string?] [v any/c] ...)