Make relative URL parsing and resolution consistent with RFC 3986 (bug#22044)

* test/lisp/url/url-parse-tests.el: Add tests covering url-generic-parse-url.
* test/lisp/url/url-expand-tests.el: Add tests covering url-expand-file-name.
* lisp/url/url-parse.el (url-generic-parse-url): Keep empty fragment
information in URL-struct.
* lisp/url/url-parse.el (url-path-and-query): Do not artificially turn empty
path and query into nil path and query, respectively.
* lisp/url/url-expand.el (url-expander-remove-relative-links): Do not turn
empty path into an absolute ("/") path.
* lisp/url/url-expand.el (url-expand-file-name): Properly resolve
fragment-only URIs. Do not just return them unchanged.
* lisp/url/url-expand.el (url-default-expander): An empty path in the relative
reference URI should not drop the last segment.

Backport:

(cherry picked from commit b792ecea1715e080ad8e232d3d154b8a25d2edfb)

3 files changed, 146 insertions, 48 deletions

diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el
index c468a7952ec..600a36dc73d 100644
--- a/lisp/url/url-expand.el
+++ b/lisp/url/url-expand.el
@@ -26,32 +26,35 @@
 (require 'url-parse)
 
 (defun url-expander-remove-relative-links (name)
-  ;; Strip . and .. from pathnames
-  (let ((new (if (not (string-match "^/" name))
-                 (concat "/" name)
-               name)))
-
-    ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
-    ;; the tests that follow are not too complicated in terms of
-    ;; looking for '..' or '../', etc.
-    (if (string-match "/\\.+$" new)
-        (setq new (concat new "/")))
-
-    ;; Remove '/./' first
-    (while (string-match "/\\(\\./\\)" new)
-      (setq new (concat (substring new 0 (match-beginning 1))
-                        (substring new (match-end 1)))))
-
-    ;; Then remove '/../'
-    (while (string-match "/\\([^/]*/\\.\\./\\)" new)
-      (setq new (concat (substring new 0 (match-beginning 1))
-                        (substring new (match-end 1)))))
-
-    ;; Remove cruft at the beginning of the string, so people that put
-    ;; in extraneous '..' because they are morons won't lose.
-    (while (string-match "^/\\.\\.\\(/\\)" new)
-      (setq new (substring new (match-beginning 1) nil)))
-    new))
+  (if (equal name "")
+      ;; An empty name is a properly valid relative URL reference/path.
+      ""
+    ;; Strip . and .. from pathnames
+    (let ((new (if (not (string-match "^/" name))
+                   (concat "/" name)
+                 name)))
+
+      ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
+      ;; the tests that follow are not too complicated in terms of
+      ;; looking for '..' or '../', etc.
+      (if (string-match "/\\.+$" new)
+          (setq new (concat new "/")))
+
+      ;; Remove '/./' first
+      (while (string-match "/\\(\\./\\)" new)
+        (setq new (concat (substring new 0 (match-beginning 1))
+                          (substring new (match-end 1)))))
+
+      ;; Then remove '/../'
+      (while (string-match "/\\([^/]*/\\.\\./\\)" new)
+        (setq new (concat (substring new 0 (match-beginning 1))
+                          (substring new (match-end 1)))))
+
+      ;; Remove cruft at the beginning of the string, so people that put
+      ;; in extraneous '..' because they are morons won't lose.
+      (while (string-match "^/\\.\\.\\(/\\)" new)
+        (setq new (substring new (match-beginning 1) nil)))
+      new)))
 
 (defun url-expand-file-name (url &optional default)
   "Convert URL to a fully specified URL, and canonicalize it.
@@ -89,8 +92,6 @@ path components followed by `..' are removed, along with the `..' itself."
   (cond
    ((= (length url) 0)                  ; nil or empty string
     (url-recreate-url default))
-   ((string-match "^#" url)             ; Offset link, use it raw
-    url)
    ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately
     url)
    (t
@@ -120,29 +121,24 @@ path components followed by `..' are removed, along with the `..' itself."
         (setf (url-host urlobj) (or (url-host urlobj) (url-host defobj))))
     (if (string= "ftp"  (url-type urlobj))
         (setf (url-user urlobj) (or (url-user urlobj) (url-user defobj))))
-    (if (string= (url-filename urlobj) "")
-        (setf (url-filename urlobj) "/"))
     ;; If the object we're expanding from is full, then we are now
     ;; full.
     (unless (url-fullness urlobj)
       (setf (url-fullness urlobj) (url-fullness defobj)))
-    (if (string-match "^/" (url-filename urlobj))
-        nil
-      (let ((query nil)
-            (file nil)
-            (sepchar nil))
-        (if (string-match "[?#]" (url-filename urlobj))
-            (setq query (substring (url-filename urlobj) (match-end 0))
-                  file (substring (url-filename urlobj) 0 (match-beginning 0))
-                  sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0)))
-          (setq file (url-filename urlobj)))
+    (let* ((pathandquery (url-path-and-query urlobj))
+           (defpathandquery (url-path-and-query defobj))
+           (file (car pathandquery))
+           (query (or (cdr pathandquery) (and (equal file "") (cdr defpathandquery)))))
+      (if (string-match "^/" (url-filename urlobj))
+          (setq file (url-expander-remove-relative-links file))
         ;; We use concat rather than expand-file-name to combine
         ;; directory and file name, since urls do not follow the same
         ;; rules as local files on all platforms.
-        (setq file (url-expander-remove-relative-links
-                    (concat (url-file-directory (url-filename defobj)) file)))
-        (setf (url-filename urlobj)
-              (if query (concat file sepchar query) file))))))
+        (setq file (url-expander-remove-relative-links
+                    (if (equal file "")
+                        (or (car (url-path-and-query defobj)) "")
+                      (concat (url-file-directory (url-filename defobj)) file)))))
+      (setf (url-filename urlobj) (if query (concat file "?" query) file)))))
 
 (provide 'url-expand)
 
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
index dbf0c386871..c3159a7e103 100644
--- a/lisp/url/url-parse.el
+++ b/lisp/url/url-parse.el
@@ -59,8 +59,6 @@ where each of PATH and QUERY are strings or nil."
           (setq path  (substring name 0 (match-beginning 0))
                 query (substring name (match-end 0)))
         (setq path name)))
-    (if (equal path "") (setq path nil))
-    (if (equal query "") (setq query nil))
     (cons path query)))
 
 (defun url-port-if-non-default (urlobj)
@@ -217,8 +215,7 @@ parses to
             (when (looking-at "#")
               (let ((opoint (point)))
                 (forward-char 1)
-                (unless (eobp)
-                  (setq fragment (buffer-substring (point) (point-max))))
+                (setq fragment (buffer-substring (point) (point-max)))
                 (delete-region opoint (point-max)))))
 
           (if (and host (string-match "%[0-9][0-9]" host))
diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el
new file mode 100644
index 00000000000..2bd28687f8d
--- /dev/null
+++ b/test/lisp/url/url-expand-tests.el
@@ -0,0 +1,105 @@
+;;; url-expand-tests.el --- Test suite for relative URI/URL resolution.
+
+;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+
+;; Author: Alain Schneble <a.s@realize.ch>
+;; Version: 1.0
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Test cases covering URI reference resolution as described in RFC3986,
+;; section 5. Reference Resolution and especially the relative resolution
+;; rules specified in section 5.2. Relative Resolution.
+
+;; Each test calls `url-expand-file-name', typically with a relative
+;; reference URI and a base URI as string and compares the result (Actual)
+;; against a manually specified URI (Expected)
+
+;;; Code:
+
+(require 'url-expand)
+(require 'ert)
+
+(ert-deftest url-expand-file-name/relative-resolution-normal-examples ()
+  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.1. Normal Examples"
+  (should (equal (url-expand-file-name "g:h"     "http://a/b/c/d;p?q") "g:h"))
+  (should (equal (url-expand-file-name "g"       "http://a/b/c/d;p?q") "http://a/b/c/g"))
+  (should (equal (url-expand-file-name "./g"     "http://a/b/c/d;p?q") "http://a/b/c/g"))
+  (should (equal (url-expand-file-name "g/"      "http://a/b/c/d;p?q") "http://a/b/c/g/"))
+  (should (equal (url-expand-file-name "/g"      "http://a/b/c/d;p?q") "http://a/g"))
+  (should (equal (url-expand-file-name "//g"     "http://a/b/c/d;p?q") "http://g"))
+  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y"))
+  (should (equal (url-expand-file-name "g?y"     "http://a/b/c/d;p?q") "http://a/b/c/g?y"))
+  (should (equal (url-expand-file-name "#s"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?q#s"))
+  (should (equal (url-expand-file-name "g#s"     "http://a/b/c/d;p?q") "http://a/b/c/g#s"))
+  (should (equal (url-expand-file-name "g?y#s"   "http://a/b/c/d;p?q") "http://a/b/c/g?y#s"))
+  (should (equal (url-expand-file-name ";x"      "http://a/b/c/d;p?q") "http://a/b/c/;x"))
+  (should (equal (url-expand-file-name "g;x"     "http://a/b/c/d;p?q") "http://a/b/c/g;x"))
+  (should (equal (url-expand-file-name "g;x?y#s" "http://a/b/c/d;p?q") "http://a/b/c/g;x?y#s"))
+  (should (equal (url-expand-file-name ""        "http://a/b/c/d;p?q") "http://a/b/c/d;p?q"))
+  (should (equal (url-expand-file-name "."       "http://a/b/c/d;p?q") "http://a/b/c/"))
+  (should (equal (url-expand-file-name "./"      "http://a/b/c/d;p?q") "http://a/b/c/"))
+  (should (equal (url-expand-file-name ".."      "http://a/b/c/d;p?q") "http://a/b/"))
+  (should (equal (url-expand-file-name "../"     "http://a/b/c/d;p?q") "http://a/b/"))
+  (should (equal (url-expand-file-name "../g"    "http://a/b/c/d;p?q") "http://a/b/g"))
+  (should (equal (url-expand-file-name "../.."   "http://a/b/c/d;p?q") "http://a/"))
+  (should (equal (url-expand-file-name "../../"  "http://a/b/c/d;p?q") "http://a/"))
+  (should (equal (url-expand-file-name "../../g" "http://a/b/c/d;p?q") "http://a/g")))
+
+(ert-deftest url-expand-file-name/relative-resolution-absolute-examples ()
+  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.2. Abnormal Examples"
+  (should (equal (url-expand-file-name "../../../g"    "http://a/b/c/d;p?q") "http://a/g"))
+  (should (equal (url-expand-file-name "../../../../g" "http://a/b/c/d;p?q") "http://a/g"))
+
+  (should (equal (url-expand-file-name "/./g"          "http://a/b/c/d;p?q") "http://a/g"))
+  (should (equal (url-expand-file-name "/../g"         "http://a/b/c/d;p?q") "http://a/g"))
+  (should (equal (url-expand-file-name "g."            "http://a/b/c/d;p?q") "http://a/b/c/g."))
+  (should (equal (url-expand-file-name ".g"            "http://a/b/c/d;p?q") "http://a/b/c/.g"))
+  (should (equal (url-expand-file-name "g.."           "http://a/b/c/d;p?q") "http://a/b/c/g.."))
+  (should (equal (url-expand-file-name "..g"           "http://a/b/c/d;p?q") "http://a/b/c/..g"))
+
+  (should (equal (url-expand-file-name "./../g"        "http://a/b/c/d;p?q") "http://a/b/g"))
+  (should (equal (url-expand-file-name "./g/."         "http://a/b/c/d;p?q") "http://a/b/c/g/"))
+  (should (equal (url-expand-file-name "g/./h"         "http://a/b/c/d;p?q") "http://a/b/c/g/h"))
+  (should (equal (url-expand-file-name "g/../h"        "http://a/b/c/d;p?q") "http://a/b/c/h"))
+  (should (equal (url-expand-file-name "g;x=1/./y"     "http://a/b/c/d;p?q") "http://a/b/c/g;x=1/y"))
+  (should (equal (url-expand-file-name "g;x=1/../y"    "http://a/b/c/d;p?q") "http://a/b/c/y"))
+
+  (should (equal (url-expand-file-name "g?y/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g?y/./x"))
+  (should (equal (url-expand-file-name "g?y/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g?y/../x"))
+  (should (equal (url-expand-file-name "g#s/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g#s/./x"))
+  (should (equal (url-expand-file-name "g#s/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g#s/../x"))
+
+  (should (equal (url-expand-file-name "http:g"        "http://a/b/c/d;p?q") "http:g")) ; for strict parsers
+  )
+
+(ert-deftest url-expand-file-name/relative-resolution-additional-examples ()
+  "Reference Resolution Examples / Arbitrary Examples"
+  (should (equal (url-expand-file-name "" "http://host/foobar") "http://host/foobar"))
+  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d") "http://a/b/c/d?y"))
+  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d/") "http://a/b/c/d/?y"))
+  (should (equal (url-expand-file-name "?y#fragment"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y#fragment"))
+  (should (equal (url-expand-file-name "#bar" "http://host") "http://host#bar"))
+  (should (equal (url-expand-file-name "#bar" "http://host/") "http://host/#bar"))
+  (should (equal (url-expand-file-name "#bar" "http://host/foo") "http://host/foo#bar"))
+  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar") "http://host/foo#bar"))
+  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar/") "http://host/foobar/foo#bar")))
+
+(provide 'url-expand-tests)
+
+;;; url-expand-tests.el ends here