Bug in new default config, reported by mflatt

svn: r12233

collects/tests/web-server/dispatchers/filesystem-map-test.ss

@@ -8,6 +8,8 @@
 (define base-dir (collection-path "web-server"))
 (define test-map (make-url->path base-dir))
 (define test-valid-map (make-url->valid-path test-map))
+(define test-filter-map (filter-url->path #rx"\\.(ss|scm)$" test-map))
+(define test-filter-valid-map (filter-url->path #rx"\\.(ss|scm)$" test-valid-map))
 
 (define (test-url->path 
          url->path file
@@ -55,4 +57,25 @@
                 (test-url->path test-valid-map (build-path "dispatchers/../dispatchers/filesystem-map.ss"))))
     (test-case "Finds valid path underneath"
                (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.ss/not-a-file")
-                               #:expected (build-path "dispatchers/filesystem-map.ss"))))))
+                               #:expected (build-path "dispatchers/filesystem-map.ss"))))
+   
+   
+   (test-suite
+    "filter-url->path"
+    (test-case "Allows right suffix"
+               (test-url->path test-filter-map (build-path "dispatchers/filesystem-map.ss")))
+    (test-case "Allows right suffix"
+               (test-url->path test-filter-map (build-path "dispatchers/filesystem-map.scm")))
+    (test-case "Disallows wrong suffix"
+               (check-exn
+                exn:fail:filesystem:exists?
+                (lambda ()
+                  (test-url->path test-filter-map (build-path "dispatchers/filesystem-map.gif")))))
+    (test-case "Disallows wrong suffix"
+               (check-exn
+                exn:fail:filesystem:exists?
+                (lambda ()
+                  (test-url->path test-filter-map (build-path "dispatchers/filesystem-map.html")))))
+    (test-case "Allows content after w/ valid"
+               (test-url->path test-filter-valid-map (build-path "dispatchers/filesystem-map.ss/extra/info")
+                               #:expected (build-path "dispatchers/filesystem-map.ss"))))))

collects/web-server/dispatchers/dispatch-servlets.ss

@@ -52,7 +52,7 @@
   ;; servlet-content-producer/path: connection request url -> void
   (define (servlet-content-producer/path conn req uri)
     (define response
-      (with-handlers ([exn:fail:filesystem:exists:servlet?
+      (with-handlers ([exn:fail:filesystem:exists?
                        (lambda (the-exn) (next-dispatcher))]
                       [(lambda (x) #t)
                        (lambda (the-exn) (responders-servlet-loading uri the-exn))])
@@ -62,7 +62,7 @@
            (define-values (servlet-path _)
              (with-handlers
                  ([void (lambda (e)
-                          (raise (make-exn:fail:filesystem:exists:servlet
+                          (raise (make-exn:fail:filesystem:exists
                                   (exn-message e)
                                   (exn-continuation-marks e))))])
                (url->path uri)))
@@ -133,11 +133,6 @@
                          (string->symbol (path->string servlet-path))
                          (lambda () (load-servlet/path servlet-path))))
   
-  ;; exn:i/o:filesystem:servlet-not-found =
-  ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
-  (define-struct (exn:fail:filesystem:exists:servlet
-                  exn:fail:filesystem:exists) ())
-  
   (define (v0.response->v1.lambda response response-path)
     (define go
       (box
@@ -196,7 +191,8 @@
                         timeouts-default-servlet)
                        (v0.response->v1.lambda s a-path))]
         [else
-         (error 'load-servlet/path "Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))
+         (error 'load-servlet/path
+                "Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))
   
   (values (lambda ()
             ;; XXX - this is broken - only out of date or specifically mentioned scripts should be flushed.  This destroys persistent state!

collects/web-server/dispatchers/filesystem-map.ss

@@ -9,7 +9,8 @@
 (provide/contract
  [url-path/c contract?]
  [make-url->path (path? . -> . url-path/c)]
- [make-url->valid-path (url-path/c . -> . url-path/c)])
+ [make-url->valid-path (url-path/c . -> . url-path/c)]
+ [filter-url->path (regexp? url-path/c . -> . url-path/c)])
 
 (define (build-path* . l)
   (if (empty? l)
@@ -50,3 +51,10 @@
       (unless (or (file-exists? p) (link-exists? p))
         (raise (make-exn:fail:filesystem:exists (string->immutable-string (format "No valid path: ~a" p)) (current-continuation-marks))))
       (values p w/o-base))))
+
+(define ((filter-url->path regex url->path) u)
+  (define-values (p w/o-base) (url->path u))
+  (if (regexp-match regex (path->string p))
+      (values p w/o-base)
+      (raise (make-exn:fail:filesystem:exists (string->immutable-string (format "Does not pass filter: ~a" p))
+                                              (current-continuation-marks)))))

collects/web-server/scribblings/dispatchers.scrbl

@@ -95,8 +95,8 @@ URLs to paths on the filesystem.
  URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL
  do not escape the @scheme[base] and removes them silently otherwise.}
 
-@defproc[(make-url->valid-path (url->path url->path?))
+@defproc[(make-url->valid-path (url->path url->pathc))
-         url->path?]{
+         url->path/c]{
  Runs the underlying @scheme[url->path], but only returns if the path
  refers to a file that actually exists. If it is does not, then the suffix
  elements of the URL are removed until a file is found. If this never occurs,
@@ -105,6 +105,15 @@ URLs to paths on the filesystem.
  This is primarily useful for dispatchers that allow path information after
  the name of a service to be used for data, but where the service is represented
  by a file. The most prominent example is obviously servlets.}
+                    
+@defproc[(filter-url->path [regex regexp?]
+                                 [url->path url-path/c])
+         url->path/c]{
+ Runs the underlying @scheme[url->path] but will only return if the path, when considered as a string,
+ matches the @scheme[regex]. This is useful to disallow strange files, like GIFs, from being considered
+ servlets when using the servlet dispatchers. It will return a @scheme[exn:fail:filesystem:exists?] exception if
+ the path does not match.
+}
 
 @; ------------------------------------------------------------
 @section[#:tag "dispatch-sequencer.ss"]{Sequencing}

collects/web-server/web-server-unit.ss

@@ -75,8 +75,10 @@
                    (servlets:make config:scripts 
                                   #:make-servlet-namespace config:make-servlet-namespace
                                   #:url->path
-                                  (fsmap:make-url->valid-path
+                                  (fsmap:filter-url->path
-                                   (fsmap:make-url->path (paths-servlet (host-paths host-info))))                                    
+                                   #rx"\\.(ss|scm)$"
+                                   (fsmap:make-url->valid-path
+                                    (fsmap:make-url->path (paths-servlet (host-paths host-info)))))
                                   #:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
                                   #:responders-servlet (responders-servlet (host-responders host-info))
                                   #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))])