Bug in new default config, reported by mflatt
svn: r12233
This commit is contained in:
Jay McCarthy
parent
90c0d48642
commit
005576bdad
|
|
@ -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"))))))
|
||||
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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)))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user