From b70bcaba50bf208a81841be2550b3f187967114c Mon Sep 17 00:00:00 2001
From: Daniel Hartwig <mandyke@gmail.com>
Date: Sat, 23 Feb 2013 15:49:20 +0800
Subject: [PATCH 4/4] extend support for relative URIs to public interface

* module/web/uri.scm (absolute-uri?, relative-uri?): New predicates.

  (validate-uri): SCHEME can be `#f' as for a relative URI.
  (build-uri): SCHEME is optional.  Validation is relaxed to also
  permit relative URIs.

  (string->uri): Fold in `string->uri*' and parse _any_ URI string,
  absolute or relative.
  (string->absolute-uri, string->relative-uri): New procedures.  Parse
  only strings representing the specific type of URI.

* module/web/http.scm (declare-absolute-uri-header!): Rename from
  `declare-uri-header!' to reflect new terminology.  Use new public uri
  interfaces to parse and validate.
  (declare-uri-header!): Rename from `declare-relative-uri-header!' to
  reflect new terminology.  Use new public uri interfaces to parsing.

  (write-uri): Do not display an absent `uri-scheme', however, do
  display the scheme even when `uri-host' is absent.  Add note to look
  at using `uri->string'.

  (parse-request-uri): Use new `string->absolute-uri' in the else
  clause.  No longer imply that scheme is `http', which was wrong for
  HTTPS.  Add note to later support "authority" form used by the CONNECT
  method.

* test-suite/tests/web-http.test ("read-request-line"):
  ("write-request-line"): Remove scheme from URIs as appropriate.

  ("entity headers", "request headers"): content-location and refer
  should also parse relative URIs.
  ("response headers"): location should not parse relative URIs.

* test-suite/tests/web-request.test ("example-1"): Do not expect any
  uri-scheme.

* test-suite/tests/web-uri.test ("build-uri"): Add tests for relative
  URIs.
  ("string->uri", "uri->string"): Add symmetric tests for handling of
  relative URIs.
  ("string->absolute-uri", "string->relative-uri"): New tests.

* doc/ref/web.texi (URIs): Add introductory note about absolute
  vs. relative URIs.  Document new procedures.

  (HTTP Headers): Note that some headers are absolute URIs.
---
 doc/ref/web.texi                  |   43 ++++++++++++----
 module/web/http.scm               |   40 ++++++++------
 module/web/uri.scm                |   39 +++++++++-----
 test-suite/tests/web-http.test    |   33 +++++++-----
 test-suite/tests/web-request.test |    2 +-
 test-suite/tests/web-uri.test     |  103 +++++++++++++++++++++++++++++++++++--
 6 files changed, 205 insertions(+), 55 deletions(-)

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 963ae3f..7cfd9e5 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -198,6 +198,15 @@ fragment identifies a part of a resource, not the resource itself.  But
 it is useful to have a fragment field in the URI record itself, so we
 hope you will forgive the inconsistency.
 
+Finally, there are URI-like objects that omit the scheme part.
+Depending on these reference, these either are or are not considered
+proper URIs.  In Guile there is a single URI record type that holds any
+URI-like object.  This manual uses the term @dfn{absolute URI} to refer
+to a URI object with a scheme, and @dfn{relative URI} to refer to one
+without.  In cases where either type will do, the term @dfn{URI} is
+used.  For example, @indicateurl{/path/to/foo} is a relative URI, where
+as all of the previous examples are absolute URIs.
+
 @example
 (use-modules (web uri))
 @end example
@@ -206,15 +215,15 @@ The following procedures can be found in the @code{(web uri)}
 module. Load it into your Guile, using a form like the above, to have
 access to them.
 
-@deffn {Scheme Procedure} build-uri scheme @
+@deffn {Scheme Procedure} build-uri [scheme] @
        [#:userinfo=@code{#f}] [#:host=@code{#f}] [#:port=@code{#f}] @
        [#:path=@code{""}] [#:query=@code{#f}] [#:fragment=@code{#f}] @
        [#:validate?=@code{#t}]
-Construct a URI object.  @var{scheme} should be a symbol, @var{port}
-either a positive, exact integer or @code{#f}, and the rest of the
-fields are either strings or @code{#f}.  If @var{validate?} is true,
-also run some consistency checks to make sure that the constructed URI
-is valid.
+Construct a URI object.  @var{scheme} should be a symbol, @var{port} a
+positive, exact integer, and the rest of the fields are strings.  Any
+field except @var{port} may also be @code{#f} to indicate it is not
+present.  If @var{validate?} is true, also run some consistency checks
+to make sure that the constructed URI is valid.
 @end deffn
 
 @deffn {Scheme Procedure} uri? obj
@@ -226,8 +235,13 @@ is valid.
 @deffnx {Scheme Procedure} uri-query uri
 @deffnx {Scheme Procedure} uri-fragment uri
 A predicate and field accessors for the URI record type.  The URI scheme
-will be a symbol, the port either a positive, exact integer or @code{#f},
-and the rest either strings or @code{#f} if not present.
+will be a symbol, the port a positive, exact integer, and the rest
+either strings.  Any field except port may be @code{#f} if not present.
+@end deffn
+
+@deffn {Scheme Procedure} absolute-uri? obj
+@deffnx {Scheme Procedure} relative-uri? obj
+Return @code{#t} iff @var{obj} is a URI object of the indicated type.
 @end deffn
 
 @deffn {Scheme Procedure} string->uri string
@@ -235,6 +249,12 @@ Parse @var{string} into a URI object.  Return @code{#f} if the string
 could not be parsed.
 @end deffn
 
+@deffn {Scheme Procedure} string->absolute-uri string
+@deffnx {Scheme Procedure} string->relative-uri string
+Parse @var{string} into a URI object of the indicated type.  Return
+@code{#f} if the string could not be parsed.
+@end deffn
+
 @deffn {Scheme Procedure} uri->string uri
 Serialize @var{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
@@ -986,9 +1006,10 @@ The entity-tag of the resource.
 @end example
 @end deftypevr
 
-@deftypevr {HTTP Header} URI location
-A URI on which a request may be completed.  Used in combination with a
-redirecting status code to perform client-side redirection.
+@deftypevr {HTTP Header} Absolute-URI location
+An absolute URI on which a request may be completed.  Used in
+combination with a redirecting status code to perform client-side
+redirection.
 @example
 (parse-header 'location "http://example.com/other")
 @result{} #<uri ...>
diff --git a/module/web/http.scm b/module/web/http.scm
index 5671330..2db64d0 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1021,6 +1021,9 @@ symbol, like ‘GET’."
    ((string= str "TRACE" start end) 'TRACE)
    (else (bad-request "Invalid method: ~a" (substring str start end)))))
 
+;; FIXME: At the moment we do not support the CONNECT form (see above)
+;; but we should and this requires to support a request-URI which is
+;; just "authority" (i.e. [userinfo "@"] host [":" port]).
 (define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
   "Parse a URI from an HTTP request line.  Note that URIs in requests do
 not have to have a scheme or host name.  The result is a URI object."
@@ -1033,12 +1036,11 @@ not have to have a scheme or host name.  The result is a URI object."
     (let* ((q (string-index str #\? start end))
            (f (string-index str #\# start end))
            (q (and q (or (not f) (< q f)) q)))
-      (build-uri 'http
-                 #:path (substring str start (or q f end))
+      (build-uri #:path (substring str start (or q f end))
                  #:query (and q (substring str (1+ q) (or f end)))
                  #:fragment (and f (substring str (1+ f) end)))))
    (else
-    (or (string->uri (substring str start end))
+    (or (string->absolute-uri (substring str start end))
         (bad-request "Invalid URI: ~a" (substring str start end))))))
 
 (define (read-request-line port)
@@ -1053,11 +1055,17 @@ three values: the method, the URI, and the version."
                 (parse-http-version line (1+ d1) (string-length line)))
         (bad-request "Bad Request-Line: ~s" line))))
 
+;; FIXME: The validation here should be reconsidered and moved to
+;; individual header validators if they do not already covered.  Then
+;; this procedure should be using uri->string.
 (define (write-uri uri port)
-  (if (uri-host uri)
+  (if (uri-scheme uri)
       (begin
         (display (uri-scheme uri) port)
-        (display "://" port)
+        (display #\:)))
+  (if (uri-host uri)
+      (begin
+        (display "//" port)
         (if (uri-userinfo uri)
             (begin
               (display (uri-userinfo uri) port)
@@ -1171,18 +1179,20 @@ treated specially, and is just returned as a plain string."
   (declare-header! name
     parse-non-negative-integer non-negative-integer? display))
 
-;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
-(define (declare-uri-header! name)
+;; emacs: (put 'declare-absolute-uri-header! 'scheme-indent-function 1)
+(define (declare-absolute-uri-header! name)
   (declare-header! name
-    (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
-    (@@ (web uri) absolute-uri?)
+    (lambda (str)
+      (or (string->absolute-uri str)
+          (bad-header-component 'absolute-uri str)))
+    absolute-uri?
     write-uri))
 
-;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
-(define (declare-relative-uri-header! name)
+;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
+(define (declare-uri-header! name)
   (declare-header! name
     (lambda (str)
-      (or ((@@ (web uri) string->uri*) str)
+      (or (string->uri str)
           (bad-header-component 'uri str)))
     uri?
     write-uri))
@@ -1449,7 +1459,7 @@ treated specially, and is just returned as a plain string."
 
 ;; Content-Location = ( absoluteURI | relativeURI )
 ;;
-(declare-relative-uri-header! "Content-Location")
+(declare-uri-header! "Content-Location")
 
 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
 ;;
@@ -1738,7 +1748,7 @@ treated specially, and is just returned as a plain string."
 
 ;; Referer = ( absoluteURI | relativeURI )
 ;;
-(declare-relative-uri-header! "Referer")
+(declare-uri-header! "Referer")
 
 ;; TE = #( t-codings )
 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
@@ -1775,7 +1785,7 @@ treated specially, and is just returned as a plain string."
 
 ;; Location = absoluteURI
 ;; 
-(declare-uri-header! "Location")
+(declare-absolute-uri-header! "Location")
 
 ;; Proxy-Authenticate = 1#challenge
 ;;
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 2e8c4a6..440e620 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -31,13 +31,14 @@
   #:use-module (ice-9 control)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
-  #:export (uri?
+  #:export (uri? absolute-uri? relative-uri?
             uri-scheme uri-userinfo uri-host uri-port
             uri-path uri-query uri-fragment
 
             build-uri
             declare-default-port! default-port default-port?
             string->uri uri->string
+            string->absolute-uri string->relative-uri
             uri-decode uri-encode
             split-and-decode-uri-path
             encode-and-join-uri-path))
@@ -54,8 +55,13 @@
   (fragment uri-fragment))
 
 (define (absolute-uri? obj)
+  "Return ‘#t’ iff OBJ is an absolute URI object."
   (and (uri? obj) (uri-scheme obj) #t))
 
+(define (relative-uri? obj)
+  "Return ‘#t’ iff OBJ is a relative URI object."
+  (and (uri? obj) (not (uri-scheme obj))))
+
 (define (uri-error message . args)
   (throw 'uri-error message args))
 
@@ -64,7 +70,7 @@
 
 (define (validate-uri scheme userinfo host port path query fragment)
   (cond
-   ((not (symbol? scheme))
+   ((and scheme (not (symbol? scheme)))
     (uri-error "Expected a symbol for the URI scheme: ~s" scheme))
    ((and (or userinfo port) (not host))
     (uri-error "Expected a host, given userinfo or port"))
@@ -80,13 +86,14 @@
          (not (eqv? (string-ref path 0) #\/)))
     (uri-error "Expected path of absolute URI to start with a /: ~a" path))))
 
-(define* (build-uri scheme #:key userinfo host port (path "") query fragment
+(define* (build-uri #:optional scheme #:key
+                    userinfo host port (path "") query fragment
                     (validate? #t))
-  "Construct a URI object.  SCHEME should be a symbol, PORT
-either a positive, exact integer or ‘#f’, and the rest of the
-fields are either strings or ‘#f’.  If VALIDATE? is true,
-also run some consistency checks to make sure that the constructed URI
-is valid."
+  "Construct a URI object.  SCHEME should be a symbol, PORT a positive,
+exact integer, and the rest of the fields are strings.  Any field except
+PORT may also be ‘#f’ to indicate it is not present.  If VALIDATE? is
+true, also run some consistency checks to make sure that the constructed
+URI is valid."
   (if validate?
       (validate-uri scheme userinfo host port path query fragment))
   (make-uri scheme userinfo host port path query fragment))
@@ -173,7 +180,7 @@ is valid."
 (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)))
@@ -194,11 +201,17 @@ could not be parsed."
      (lambda (k)
        #f)))
 
-(define (string->uri string)
-  "Parse STRING into a URI object.  Return ‘#f’ if the string
+(define (string->absolute-uri string)
+  "Parse STRING into an absolute URI object.  Return ‘#f’ if the string
+could not be parsed."
+  (let ((uri (string->uri string)))
+    (and (absolute-uri? uri) uri)))
+
+(define (string->relative-uri string)
+  "Parse STRING into a relative URI object.  Return ‘#f’ if the string
 could not be parsed."
-  (let ((uri (string->uri* string)))
-    (and uri (uri-scheme uri) uri)))
+  (let ((uri (string->uri string)))
+    (and (relative-uri? uri) uri)))
 
 (define *default-ports* (make-hash-table))
 
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 6fa16bd..80dbd55 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -132,8 +132,7 @@
 (with-test-prefix "read-request-line"
   (pass-if-read-request-line "GET / HTTP/1.1"
                              GET
-                             (build-uri 'http
-                                        #:path "/")
+                             (build-uri #:path "/")
                              (1 . 1))
   (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
                              GET
@@ -143,21 +142,18 @@
                              (1 . 1))
   (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
                              GET
-                             (build-uri 'http
-                                        #:path "/pub/WWW/TheProject.html")
+                             (build-uri #:path "/pub/WWW/TheProject.html")
                              (1 . 1))
   (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
                              HEAD
-                             (build-uri 'http
-                                        #:path "/etc/hosts"
+                             (build-uri #:path "/etc/hosts"
                                         #:query "foo=bar")
                              (1 . 1)))
 
 (with-test-prefix "write-request-line"
   (pass-if-write-request-line "GET / HTTP/1.1"
                               GET
-                              (build-uri 'http
-                                         #:path "/")
+                              (build-uri #:path "/")
                               (1 . 1))
   ;;; FIXME: Test fails due to scheme, host always being removed.
   ;;; However, it should be supported to request these be present, and
@@ -170,13 +166,11 @@
   ;;                             (1 . 1))
   (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
                               GET
-                              (build-uri 'http
-                                         #:path "/pub/WWW/TheProject.html")
+                              (build-uri #:path "/pub/WWW/TheProject.html")
                               (1 . 1))
   (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
                               HEAD
-                              (build-uri 'http
-                                         #:path "/etc/hosts"
+                              (build-uri #:path "/etc/hosts"
                                          #:query "foo=bar")
                               (1 . 1)))
 
@@ -252,6 +246,12 @@
   (pass-if-parse content-length "010" 10)
   (pass-if-parse content-location "http://foo/"
                  (build-uri 'http #:host "foo" #:path "/"))
+  (pass-if-parse content-location "//foo/"
+                 (build-uri #:host "foo" #:path "/"))
+  (pass-if-parse content-location "/etc/foo"
+                 (build-uri #:path "/etc/foo"))
+  (pass-if-parse content-location "foo"
+                 (build-uri #:path "foo"))
   (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
   (pass-if-parse content-range "bytes */*" '(bytes * *))
   (pass-if-parse content-range "bytes */30" '(bytes * 30))
@@ -315,6 +315,12 @@
   (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30)))
   (pass-if-parse referer "http://foo/bar?baz"
                  (build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
+  (pass-if-parse referer "//foo/bar?baz"
+                 (build-uri #:host "foo" #:path "/bar" #:query "baz"))
+  (pass-if-parse referer "/etc/foo"
+                 (build-uri #:path "/etc/foo"))
+  (pass-if-parse referer "foo"
+                 (build-uri #:path "foo"))
   (pass-if-parse te "trailers" '((trailers)))
   (pass-if-parse te "trailers,foo" '((trailers) (foo)))
   (pass-if-parse user-agent "guile" "guile"))
@@ -329,6 +335,9 @@
   (pass-if-parse etag "W/\"foo\"" '("foo" . #f))
   (pass-if-parse location "http://other-place"
                  (build-uri 'http #:host "other-place"))
+  (pass-if-any-error location "//other-place")
+  (pass-if-any-error location "/etc/foo")
+  (pass-if-any-error location "foo")
   (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
                  '((basic (realm . "guile"))))
   (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test
index 8cf1c2e..1574d69 100644
--- a/test-suite/tests/web-request.test
+++ b/test-suite/tests/web-request.test
@@ -53,7 +53,7 @@ Accept-Language: en-gb, en;q=0.9\r
     
     (pass-if (equal? (request-method r) 'GET))
     
-    (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))
+    (pass-if (equal? (request-uri r) (build-uri #:path "/qux")))
     
     (pass-if (equal? (read-request-body r) #f))
 
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 3f6e7e3..5db1442 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -121,8 +121,23 @@
 
   (pass-if-uri-exception "http://foo@"
                          "Expected.*host"
-                         (build-uri 'http #:userinfo "foo")))
+                         (build-uri 'http #:userinfo "foo"))
 
+  (pass-if "//host/etc/foo"
+    (uri=? (build-uri #:host "host"
+                      #:path "/etc/foo")
+           #:host "host"
+           #:path "/etc/foo"))
+
+  (pass-if "/path/to/some/foo?query"
+    (uri=? (build-uri #:path "/path/to/some/foo"
+                      #:query "query")
+           #:path "/path/to/some/foo"
+           #:query "query"))
+
+  (pass-if "nextdoc/foo"
+    (uri=? (build-uri #:path "nextdoc/foo")
+           #:path "nextdoc/foo")))
 
 (with-test-prefix "string->uri"
   (pass-if "ftp:"
@@ -210,7 +225,30 @@
   (pass-if "file:///etc/hosts"
     (uri=? (string->uri "file:///etc/hosts")
            #:scheme 'file
-           #:path "/etc/hosts")))
+           #:path "/etc/hosts"))
+
+  (pass-if "/"
+    (uri=? (string->uri "/")
+           #:path "/"))
+
+  (pass-if "/path/to/foo"
+    (uri=? (string->uri "/path/to/foo")
+           #:path "/path/to/foo"))
+
+  (pass-if "//example.org"
+    (uri=? (string->uri "//example.org")
+           #:host "example.org"
+           #:path ""))
+
+  (pass-if "//bar@example.org/path/to/foo"
+    (uri=? (string->uri "//bar@example.org/path/to/foo")
+           #:userinfo "bar"
+           #:host "example.org"
+           #:path "/path/to/foo"))
+
+  (pass-if "nextdoc/foo"
+    (uri=? (string->uri "nextdoc/foo")
+           #:path "nextdoc/foo")))
 
 (with-test-prefix "uri->string"
   (pass-if "ftp:"
@@ -248,7 +286,66 @@
   
   (pass-if "http://foo:/"
     (equal? "http://foo/"
-            (uri->string (string->uri "http://foo:/")))))
+            (uri->string (string->uri "http://foo:/"))))
+
+  (pass-if "/"
+    (equal? "/"
+            (uri->string (string->uri "/"))))
+
+  (pass-if "/path/to/foo"
+    (equal? "/path/to/foo"
+            (uri->string (string->uri "/path/to/foo"))))
+
+  (pass-if "//example.org"
+    (equal? "//example.org"
+            (uri->string (string->uri "//example.org"))))
+
+  (pass-if "//bar@example.org/path/to/foo"
+    (equal? "//bar@example.org/path/to/foo"
+            (uri->string (string->uri "//bar@example.org/path/to/foo"))))
+
+  (pass-if "nextdoc/foo"
+    (equal? "nextdoc/foo"
+            (uri->string (string->uri "nextdoc/foo")))))
+
+(with-test-prefix "string->absolute-uri"
+  (pass-if "ftp:"
+    (uri=? (string->absolute-uri "ftp:")
+           #:scheme 'ftp
+           #:path ""))
+
+  (pass-if "/"
+    (not (string->absolute-uri "/")))
+
+  (pass-if "/path/to/foo"
+    (not (string->absolute-uri "/path/to/foo")))
+
+  (pass-if "//example.org"
+    (not (string->absolute-uri "//example.org")))
+
+  (pass-if "nextdoc/foo"
+    (not (string->absolute-uri "nextdoc/foo"))))
+
+(with-test-prefix "string->relative-uri"
+  (pass-if "ftp:"
+    (not (string->relative-uri "ftp:")))
+
+  (pass-if "/"
+    (uri=? (string->relative-uri "/")
+           #:path "/"))
+
+  (pass-if "/path/to/foo"
+    (uri=? (string->relative-uri "/path/to/foo")
+           #:path "/path/to/foo"))
+
+  (pass-if "//example.org"
+    (uri=? (string->relative-uri "//example.org")
+           #:host "example.org"
+           #:path ""))
+
+  (pass-if "nextdoc/foo"
+    (uri=? (string->relative-uri "nextdoc/foo")
+           #:path "nextdoc/foo")))
 
 (with-test-prefix "decode"
   (pass-if "foo%20bar"
-- 
1.7.10.4

