Fixing in an error in how paths that went outside the filesystem to

URL map were handled.

Previously, only ".." at the beginning of the URL were checked; now it
looks at the entire URL for a path that ultimately leaves the base.

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-case "Strips out bad '..'s"
-               (test-url->path test-map (build-path "dispatchers/filesystem-map.rkt")
+               (check-exn exn:fail? (λ () (test-map (string->url "http://test.com/../../dispatchers/filesystem-map.rkt")))))
-                               #:url-string "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-case "Strips out bad '..'s"
-                (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.rkt")
+               (check-exn exn:fail? (λ () (test-valid-map (string->url "http://test.com/../../dispatchers/filesystem-map.rkt")))))
-                                #:url-string "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"))))))
+

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

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* path-from-url)
-     (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)))))
      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)

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?)])
 

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] ...)