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

svn: r1779

collects/help/private/gui.ss

@@ -8,6 +8,7 @@
            (lib "etc.ss")
            (lib "unitsig.ss")
            (lib "list.ss")
+           (lib "file.ss")
            
            (lib "string-constant.ss" "string-constants")
            (lib "external.ss" "browser")
@@ -15,6 +16,7 @@
            (lib "browser-sig.ss" "browser")
            (lib "url-sig.ss" "net")
            (lib "url-structs.ss" "net")
+           (lib "uri-codec.ss" "net")
            "sig.ss"
            "../bug-report.ss"
            (lib "bday.ss" "framework" "private")
@@ -137,7 +139,7 @@
                      
                      ;; send the url off to another browser
                      [(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)
                                (ask-user-about-separate-browser))
                           (preferences:get 'drscheme:help-desk:separate-browser))
@@ -556,8 +558,17 @@
                          (lambda (b e)
                            (let ([f (get-file)])
                              (when f
-                               (send t set-value (string-append "file:" (path->string f)))
+                               (send t set-value (encode-file-path-as-url f))
                                (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 result #f)
         (define (ok-callback b e)

collects/net/url-unit.ss

@@ -62,13 +62,6 @@
                                            args)))))
             (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
         (lambda (url)
           (let ((scheme (url-scheme url))
@@ -78,13 +71,6 @@
                 (path (url-path url))
                 (query (url-query url))
                 (fragment (url-fragment url)))
-            (cond
-             ((and scheme (string=? scheme "file"))
-              (string-append "file:" 
-			     (url->file-path url)
-                             (or (and (not fragment) "")
-                                 (string-append "#" fragment))))
-             (else
             (let ((sa string-append))
               (sa (if scheme (sa scheme ":") "")
                   (if (or user host port)
@@ -100,7 +86,7 @@
                   (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)) ""))))))))
+                  (if fragment (sa "#" (uri-encode fragment)) ""))))))
 
       ;; url->default-port : url -> num
       (define url->default-port
@@ -155,9 +141,13 @@
             server->client)))
 
       ;; 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)
         (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
@@ -371,7 +361,7 @@
                            "("                ; <3  slashslash-opt
                            "//"
                            "([^:/@;?#]*@)?"   ; =4  user-at-opt
-                           "([^:/@;?#]+)?"    ; =5  host-opt
+                           "([^:/@;?#]*)?"    ; =5  host-opt
                            "(:[0-9]*)?"       ; =6  colon-port-opt
                            ")?"               ; >3  slashslash-opt
                            ")?"               ; >1  front-opt
@@ -381,39 +371,6 @@
                            "[ \t\f\r\n]*"
                            "$"))))
           (lambda (str)
-            (let ([m (regexp-match #rx"^[ \t\f\r\n]*file:(.*)$" str)])
-              ;; File scheme:
-              (if m
-                  (let ([path+fragment (regexp-match #rx"^([^#]*)(#(.*))?$" (cadr m))])
-                    (let ([path (cadr path+fragment)]
-                          [fragment (caddr path+fragment)])
-                      (if (or (relative-path? path)
-                              (absolute-path? path))
-			  (let-values ([(root elems kind)
-					(let loop ([path (simplify-path path)][accum null][kind #f])
-					  (let-values ([(base name dir?) (split-path path)])
-					    (let ([kind (or kind
-							    (if dir? 'dir 'file))])
-					      (cond
-					       [(path? base)
-						(loop base (cons name accum) kind)]
-					       [(eq? base 'relative)
-						(values #f (cons name accum) kind)]
-					       [else
-						(values path accum kind)]))))])
-			    (make-url "file"
-				      #f  ; user
-				      (and root (path->string root))  ; host
-				      #f  ; port
-				      (absolute-path? path)
-                                      (append (map (λ (x) (make-path/param (path->string x) '())) elems)
-					      (if (eq? kind 'dir)
-						  (list (make-path/param "" '()))
-						  null))
-				      '()  ; query
-				      fragment))
-                          (url-error "scheme 'file' path ~s neither relative nor absolute" path))))
-                  ;; Other scheme:
             (let ((match (regexp-match-positions rx str)))
               (if match
                   (let* ((get-str (lambda (pos skip-left skip-right)
@@ -453,7 +410,7 @@
                                 (if q (form-urlencoded->alist q) '()))
                               (uri-decode/maybe (get-str 9  1 0)) ; fragment
                               ))
-                        (url-error "Invalid URL string: ~e" str))))))))
+                  (url-error "Invalid URL string: ~e" str))))))
 
       (define (uri-decode/maybe f)
         ;; If #f, and leave unmolested any % that is followed by hex digit

collects/tests/mzscheme/net.ss

@@ -180,6 +180,12 @@
              "/")
   (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)
              "http://www.drscheme.org")
   (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)
              "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")
         string->url/vec
         "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")