web client: correctly handle uri-query, etc. in relative URI headers

* module/web/uri.scm (uri-pat): Make scheme part optional.
  (string->uri*): New private procedure to also parse relative URIs.
* module/web/http.scm (declare-relative-uri-header!): Use that.

diff --git a/module/web/http.scm b/module/web/http.scm
index f8dba30..216fddd 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1182,21 +1182,15 @@ treated specially, and is just returned as a plain string."
 (define (declare-uri-header! name)
   (declare-header! name
     (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
-    uri?
+    (@@ (web uri) absolute-uri?)
     write-uri))
 
 ;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
 (define (declare-relative-uri-header! name)
   (declare-header! name
     (lambda (str)
-      ;; XXX: Attempt to build an absolute URI, and fall back to a URI
-      ;; with no scheme to represent a relative URI.
-      ;; See <http://bugs.gnu.org/12827> for ideas to fully support
-      ;; relative URIs (aka. "URI references").
-      (or (string->uri str)                       ; absolute URI
-          (build-uri #f                           ; relative URI
-                     #:path str
-                     #:validate? #f)))
+      (or ((@@ (web uri) string->uri*) str)
+          (bad-header-component 'uri str)))
     uri?
     write-uri))
 

diff --git a/module/web/uri.scm b/module/web/uri.scm
index 6ff0076..b688ea8 100644 (file)
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -53,6 +53,9 @@
   (query uri-query)
   (fragment uri-fragment))
 
+(define (absolute-uri? x)
+  (and (uri? x) (uri-scheme x) #t))
+
 (define (uri-error message . args)
   (throw 'uri-error message args))
 
@@ -165,21 +168,21 @@ is valid."
 (define fragment-pat
   ".*")
 (define uri-pat
-  (format #f "^(~a):(//~a)?(~a)(\\?(~a))?(#(~a))?$"
+  (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
           scheme-pat authority-pat path-pat query-pat fragment-pat))
 (define uri-regexp
   (make-regexp uri-pat))
 
-(define (string->uri string)
+(define (string->uri* string)
   "Parse STRING into a URI object.  Return ‘#f’ if the string
 could not be parsed."
   (% (let ((m (regexp-exec uri-regexp string)))
        (if (not m) (abort))
-       (let ((scheme (string->symbol
-                      (string-downcase (match:substring m 1))))
-             (authority (match:substring m 2))
-             (path (match:substring m 3))
-             (query (match:substring m 5))
+       (let ((scheme (let ((str (match:substring m 2)))
+                       (and str (string->symbol (string-downcase str)))))
+             (authority (match:substring m 3))
+             (path (match:substring m 4))
+             (query (match:substring m 6))
              (fragment (match:substring m 7)))
          (call-with-values
              (lambda ()
@@ -191,6 +194,12 @@ could not be parsed."
      (lambda (k)
        #f)))
 
+(define (string->uri string)
+  "Parse STRING into a URI object.  Return ‘#f’ if the string
+could not be parsed."
+  (let ((uri (string->uri* string)))
+    (and uri (uri-scheme uri) uri)))
+
 (define *default-ports* (make-hash-table))
 
 (define (declare-default-port! scheme port)
@@ -208,8 +217,7 @@ could not be parsed."
   "Serialize URI to a string.  If the URI has a port that is the
 default port for its scheme, the port is not included in the
 serialization."
-  (let* ((scheme-str (string-append
-                      (symbol->string (uri-scheme uri)) ":"))
+  (let* ((scheme (uri-scheme uri))
          (userinfo (uri-userinfo uri))
          (host (uri-host uri))
          (port (uri-port uri))
@@ -217,7 +225,9 @@ serialization."
          (query (uri-query uri))
          (fragment (uri-fragment uri)))
     (string-append
-     scheme-str
+     (if scheme
+         (string-append (symbol->string scheme) ":")
+         "")
      (if host
          (string-append "//"
                         (if userinfo (string-append userinfo "@")