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

fixed up file: urls and fixed a bug in the parsing of urls with empty string host names

Browse Source 
svn: r1779
This commit is contained in:
Robby Findler 2006-01-07 03:25:26 +00:00
parent 00dece4975
commit aa5d3f7378
3 changed files with 95 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/help/private/gui.ss
View File

@ -8,6 +8,7 @@
(lib "etc.ss") (lib "etc.ss")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "list.ss") (lib "list.ss")
(lib "file.ss")
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "external.ss" "browser") (lib "external.ss" "browser")
@ -15,6 +16,7 @@
(lib "browser-sig.ss" "browser") (lib "browser-sig.ss" "browser")
(lib "url-sig.ss" "net") (lib "url-sig.ss" "net")
(lib "url-structs.ss" "net") (lib "url-structs.ss" "net")
(lib "uri-codec.ss" "net")
"sig.ss" "sig.ss"
"../bug-report.ss" "../bug-report.ss"
(lib "bday.ss" "framework" "private") (lib "bday.ss" "framework" "private")
@ -137,7 +139,7 @@
;; send the url off to another browser ;; send the url off to another browser
[(or (and (string? (url-scheme url)) [(or (and (string? (url-scheme url))
(not (equal? (url-scheme url) "http"))) (not (member (url-scheme url) '("http"))))
(and (preferences:get 'drscheme:help-desk:ask-about-external-urls) (and (preferences:get 'drscheme:help-desk:ask-about-external-urls)
(ask-user-about-separate-browser)) (ask-user-about-separate-browser))
(preferences:get 'drscheme:help-desk:separate-browser)) (preferences:get 'drscheme:help-desk:separate-browser))
@ -556,8 +558,17 @@
(lambda (b e) (lambda (b e)
(let ([f (get-file)]) (let ([f (get-file)])
(when f (when f
(send t set-value (string-append "file:" (path->string f))) (send t set-value (encode-file-path-as-url f))
(update-ok)))))) (update-ok))))))
(define (encode-file-path-as-url f)
(apply
string-append
"file:"
(map
(λ (x) (string-append "/" (uri-path-segment-encode (path->string x))))
(explode-path f))))
(define spacer (make-object vertical-pane% p)) (define spacer (make-object vertical-pane% p))
(define result #f) (define result #f)
(define (ok-callback b e) (define (ok-callback b e)

171
collects/net/url-unit.ss
View File

@ -62,13 +62,6 @@
args))))) args)))))
(raise (make-url-exception s (current-continuation-marks)))))) (raise (make-url-exception s (current-continuation-marks))))))
(define (url->file-path url)
(path->string
(apply build-path (or (url-host url) 'same)
(map (lambda (x) (if (equal? x "") 'same x))
(map path/param-path
(url-path url))))))
(define url->string (define url->string
(lambda (url) (lambda (url)
(let ((scheme (url-scheme url)) (let ((scheme (url-scheme url))
@ -78,29 +71,22 @@
(path (url-path url)) (path (url-path url))
(query (url-query url)) (query (url-query url))
(fragment (url-fragment url))) (fragment (url-fragment url)))
(cond (let ((sa string-append))
((and scheme (string=? scheme "file")) (sa (if scheme (sa scheme ":") "")
(string-append "file:" (if (or user host port)
(url->file-path url) (sa
(or (and (not fragment) "") "//"
(string-append "#" fragment)))) (if user (sa (uri-encode user) "@") "")
(else (if host host "")
(let ((sa string-append)) (if port (sa ":" (number->string port)) "")
(sa (if scheme (sa scheme ":") "") ; There used to be a "/" here, but that causes an
(if (or user host port) ; extra leading slash -- wonder why it ever worked!
(sa )
"//" "")
(if user (sa (uri-encode user) "@") "") (combine-path-strings (url-path-absolute? url) path)
(if host host "") ;(if query (sa "?" (uri-encode query)) "")
(if port (sa ":" (number->string port)) "") (if (null? query) "" (sa "?" (alist->form-urlencoded query)))
; There used to be a "/" here, but that causes an (if fragment (sa "#" (uri-encode fragment)) ""))))))
; extra leading slash -- wonder why it ever worked!
)
"")
(combine-path-strings (url-path-absolute? url) path)
;(if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))))))
;; url->default-port : url -> num ;; url->default-port : url -> num
(define url->default-port (define url->default-port
@ -155,9 +141,13 @@
server->client))) server->client)))
;; file://get-pure-port : url -> in-port ;; file://get-pure-port : url -> in-port
(define file://get-pure-port (define (file://get-pure-port url)
(lambda (url) (open-input-file
(open-input-file (url->file-path url)))) (apply
build-path
(map
path/param-path
(url-path url)))))
(define (schemeless-url url) (define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
@ -371,7 +361,7 @@
"(" ; <3 slashslash-opt "(" ; <3 slashslash-opt
"//" "//"
"([^:/@;?#]*@)?" ; =4 user-at-opt "([^:/@;?#]*@)?" ; =4 user-at-opt
"([^:/@;?#]+)?" ; =5 host-opt "([^:/@;?#]*)?" ; =5 host-opt
"(:[0-9]*)?" ; =6 colon-port-opt "(:[0-9]*)?" ; =6 colon-port-opt
")?" ; >3 slashslash-opt ")?" ; >3 slashslash-opt
")?" ; >1 front-opt ")?" ; >1 front-opt
@ -381,79 +371,46 @@
"[ \t\f\r\n]*" "[ \t\f\r\n]*"
"$")))) "$"))))
(lambda (str) (lambda (str)
(let ([m (regexp-match #rx"^[ \t\f\r\n]*file:(.*)$" str)]) (let ((match (regexp-match-positions rx str)))
;; File scheme: (if match
(if m (let* ((get-str (lambda (pos skip-left skip-right)
(let ([path+fragment (regexp-match #rx"^([^#]*)(#(.*))?$" (cadr m))]) (let ((pair (list-ref match pos)))
(let ([path (cadr path+fragment)] (if pair
[fragment (caddr path+fragment)]) (substring str
(if (or (relative-path? path) (+ (car pair) skip-left)
(absolute-path? path)) (- (cdr pair) skip-right))
(let-values ([(root elems kind) #f))))
(let loop ([path (simplify-path path)][accum null][kind #f]) (get-num (lambda (pos skip-left skip-right)
(let-values ([(base name dir?) (split-path path)]) (let ((s (get-str pos skip-left skip-right)))
(let ([kind (or kind (if s (string->number s) #f))))
(if dir? 'dir 'file))]) (host (get-str 5 0 0))
(cond (path (get-str 7 0 0))
[(path? base) (scheme (get-str 2 0 1)))
(loop base (cons name accum) kind)] (when (string? scheme) (string-lowercase! scheme))
[(eq? base 'relative) (when (string? host) (string-lowercase! host))
(values #f (cons name accum) kind)] (make-url scheme
[else (uri-decode/maybe (get-str 4 0 1)) ; user
(values path accum kind)]))))]) host
(make-url "file" (get-num 6 1 0) ; port
#f ; user (and (not (= 0 (string-length path)))
(and root (path->string root)) ; host (char=? #\/ (string-ref path 0)))
#f ; port (separate-path-strings
(absolute-path? path) ;; If path is "" and the input is an absolute URL
(append (map (λ (x) (make-path/param (path->string x) '())) elems) ;; with a hostname, then the intended path is "/",
(if (eq? kind 'dir) ;; but the URL is missing a "/" at the end.
(list (make-path/param "" '())) path
null)) #;
'() ; query (if (and (string=? path "")
fragment)) host)
(url-error "scheme 'file' path ~s neither relative nor absolute" path)))) "/"
;; Other scheme: path))
(let ((match (regexp-match-positions rx str))) ;(uri-decode/maybe (get-str 8 1 0)) ;
(if match ;query
(let* ((get-str (lambda (pos skip-left skip-right) (let ([q (get-str 8 1 0)])
(let ((pair (list-ref match pos))) (if q (form-urlencoded->alist q) '()))
(if pair (uri-decode/maybe (get-str 9 1 0)) ; fragment
(substring str ))
(+ (car pair) skip-left) (url-error "Invalid URL string: ~e" str))))))
(- (cdr pair) skip-right))
#f))))
(get-num (lambda (pos skip-left skip-right)
(let ((s (get-str pos skip-left skip-right)))
(if s (string->number s) #f))))
(host (get-str 5 0 0))
(path (get-str 7 0 0))
(scheme (get-str 2 0 1)))
(when (string? scheme) (string-lowercase! scheme))
(when (string? host) (string-lowercase! host))
(make-url scheme
(uri-decode/maybe (get-str 4 0 1)) ; user
host
(get-num 6 1 0) ; port
(and (not (= 0 (string-length path)))
(char=? #\/ (string-ref path 0)))
(separate-path-strings
;; If path is "" and the input is an absolute URL
;; with a hostname, then the intended path is "/",
;; but the URL is missing a "/" at the end.
path
#;
(if (and (string=? path "")
host)
"/"
path))
;(uri-decode/maybe (get-str 8 1 0)) ;
;query
(let ([q (get-str 8 1 0)])
(if q (form-urlencoded->alist q) '()))
(uri-decode/maybe (get-str 9 1 0)) ; fragment
))
(url-error "Invalid URL string: ~e" str))))))))
(define (uri-decode/maybe f) (define (uri-decode/maybe f)
;; If #f, and leave unmolested any % that is followed by hex digit ;; If #f, and leave unmolested any % that is followed by hex digit

13
collects/tests/mzscheme/net.ss
View File

@ -180,6 +180,12 @@
"/") "/")
(test-s->u (vector #f #f #f #f #f '() '() #f) (test-s->u (vector #f #f #f #f #f '() '() #f)
"") "")
(test-s->u (vector "http" #f #f #f #t '(#("")) '() #f)
"http:/")
(test-s->u (vector "http" #f "" #f #t '(#("")) '() #f)
"http:///")
(test-s->u (vector "http" #f "www.drscheme.org" #f #f '() '() #f) (test-s->u (vector "http" #f "www.drscheme.org" #f #f '() '() #f)
"http://www.drscheme.org") "http://www.drscheme.org")
(test-s->u (vector "http" #f "www.drscheme.org" #f #t '(#("")) '() #f) (test-s->u (vector "http" #f "www.drscheme.org" #f #t '(#("")) '() #f)
@ -234,7 +240,14 @@
(test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) '() #f) (test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) '() #f)
"http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;")
;; test file: urls
(test-s->u (vector "file" #f #f #f #t '(#("abc") #("def.html")) '() #f)
"file:/abc/def.html")
(test-s->u (vector "file" #f "localhost" #f #t '(#("abc") #("def.html")) '() #f)
"file://localhost/abc/def.html")
;; test case sensitivity
(test (vector "http" "ROBBY" "www.drscheme.org" 80 #t '(#("INDEX.HTML" "XXX")) '((T . "P")) "YYY") (test (vector "http" "ROBBY" "www.drscheme.org" 80 #t '(#("INDEX.HTML" "XXX")) '((T . "P")) "YYY")
string->url/vec string->url/vec
"HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")