diff --git a/collects/tests/web-server/dispatchers/filesystem-map-test.ss b/collects/tests/web-server/dispatchers/filesystem-map-test.ss index 05f070a377..81a6e321e2 100644 --- a/collects/tests/web-server/dispatchers/filesystem-map-test.ss +++ b/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")))))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 1a1a9ed548..d1cd59bc81 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/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! diff --git a/collects/web-server/dispatchers/filesystem-map.ss b/collects/web-server/dispatchers/filesystem-map.ss index acbd267f0d..bed3e607e5 100644 --- a/collects/web-server/dispatchers/filesystem-map.ss +++ b/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))))) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 350e008994..dc8451dfb7 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/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?)) - url->path?]{ +@defproc[(make-url->valid-path (url->path url->pathc)) + 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} diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 795f65f626..b1f56c7408 100644 --- a/collects/web-server/web-server-unit.ss +++ b/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:make-url->path (paths-servlet (host-paths host-info)))) + (fsmap:filter-url->path + #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)))])