suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

path->url: ensure directory paths have a trailing slash

Browse Source 
If a path to a directory is converted to an URL it loses
           its trailing path separator.
           This can lead to a bug if the URL is used as a base URL to
           build other URLs (e.g. combine-url/relative).
This commit is contained in:
Philippe Mechai 2012-11-06 22:59:12 +01:00 committed by Matthew Flatt
parent 36bfae9497
commit d8ff661118
1 changed files with 47 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/net/url.rkt
View File

@ -558,47 +558,53 @@
";"))
(define (path->url path)
(let ([url-path
(let loop ([path (simplify-path path #f)][accum null])
(let-values ([(base name dir?) (split-path path)])
(cond
[(not base)
(append (map
(lambda (s)
(make-path/param s null))
(if (eq? (path-convention-type path) 'windows)
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8 (path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
;; \\?\<drive>: path:
(regexp-split #rx"[/\\]+" (substring s 4))]
[(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
;; \\?\ UNC path:
(regexp-split #rx"[/\\]+" (substring s 7))]
[(regexp-match? #rx"^[/\\]" s)
;; UNC path:
(regexp-split #rx"[/\\]+" s)]
[else
(list s)]))
;; On other platforms, we drop the root:
null))
accum)]
[else
(let ([accum (cons (make-path/param
(if (symbol? name)
name
(bytes->string/utf-8
(path-element->bytes name)))
null)
accum)])
(if (eq? base 'relative)
accum
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
(let* ([spath (simplify-path path #f)]
[dir? (let-values ([(b n dir?) (split-path spath)]) dir?)]
;; If original path is a directory the resulting URL
;; should have a trailing forward slash
[url-tail (if dir? (list (make-path/param "" null)) null)]
[url-path
(let loop ([path spath][accum null])
(let-values ([(base name dir?) (split-path path)])
(cond
[(not base)
(append (map
(lambda (s)
(make-path/param s null))
(if (eq? (path-convention-type path) 'windows)
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8 (path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
;; \\?\<drive>: path:
(regexp-split #rx"[/\\]+" (substring s 4))]
[(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
;; \\?\ UNC path:
(regexp-split #rx"[/\\]+" (substring s 7))]
[(regexp-match? #rx"^[/\\]" s)
;; UNC path:
(regexp-split #rx"[/\\]+" s)]
[else
(list s)]))
;; On other platforms, we drop the root:
null))
accum)]
[else
(let ([accum (cons (make-path/param
(if (symbol? name)
name
(bytes->string/utf-8
(path-element->bytes name)))
null)
accum)])
(if (eq? base 'relative)
accum
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) (append url-path url-tail) '() #f)))
(define (url->path url [kind (system-path-convention-type)])
(file://->path url kind))