[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#12827: [PATCH] Tweak web modules, support relative URIs
|
From: |
Andy Wingo |
|
Subject: |
bug#12827: [PATCH] Tweak web modules, support relative URIs |
|
Date: |
Mon, 20 Jun 2016 21:52:40 +0200 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) |
I would like to apply this patch, to master at least. Any objections?
We need documentation for the new exports, is the only missing thing.
Andy
On Sat 16 Mar 2013 15:25, Daniel Hartwig <address@hidden> writes:
> On 13 March 2013 19:05, Andy Wingo <address@hidden> wrote:
>> What's the status here, Daniel? Would be nice to fix this bug one way
>> or another for 2.0.8.
>
> Latest work attached, updated as per discussion with Mark.
>
> Still missing #:base-uri (RFC 3986 #5.2) and some polish.
>
> For the docs, I believe it best to follow the RFC and leave the
> existing section on URIs as-is, followed by a new section introducing
> the other types. This will help avoid conflating the two concepts of
> URI and URI-reference.
>
> Regarding the interface. There is now an abundance of constructors
> and string converters, one for each specific type. It is also
> somewhat inconsistent in that there is no need for multiple accessors
> or âuri*->stringâ procedures. An alternative interface might employ a
> single constructor similar to âmake-timeâ, using a set of
> variables/symbols to represent the desired type:
>
> build-uri-reference arg ... [#:type=âuriâ]
> string->uri-reference str [type]
>
> where TYPE is one of âuriâ, âuri-referenceâ, ârelative-refâ,
> âabsolute-uriâ. Perhaps even have a single âbuild-uriâ with these
> semantics.
>
> Comments, ideas?
>
> From 26655a2ae8a2864ea867ed5240eff5d0bb916a49 Mon Sep 17 00:00:00 2001
> From: Daniel Hartwig <address@hidden>
> Date: Sat, 16 Mar 2013 21:18:34 +0800
> Subject: [PATCH] web: add support for URI-reference
>
> * doc/ref/web.texi (URIs): Fragments are properly part of a URI, so
> remove the incorrect note.
>
> * module/web/uri.scm (uri-reference?): New base type predicate.
> (uri?, relative-ref?, absolute-uri?): Specific predicates.
>
> (validate-uri-reference): Strict validation.
> (validate-uri, validate-relative-ref, validate-absolute-uri):
> Specific validators.
>
> (build-uri-reference, build-relative-ref, build-absolute-uri):
> New constructors.
>
> (string->uri*): Add `validate' argument.
> (string->uri, string->uri-reference, string->relative-ref):
> (string->absolute-uri): Specific constructors.
>
> * module/web/http.scm (parse-request-uri): Use `build-uri-reference',
> and result is a URI-reference, not URI, object. No longer infer an
> absent `uri-scheme' is `http'.
>
> (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'.
>
> (declare-absolute-uri-header!): Update. Rename from
> `declare-uri-header!'.
>
> (declare-uri-reference-header!): Update. Rename from
> `declare-relative-uri-header!'.
>
> * test-suite/tests/web-uri.test ("build-uri-reference"):
> ("string->uri-reference"): Add.
>
> ("uri->string"): Also tests for relative-refs.
>
> * test-suite/tests/web-http.test ("read-request-line"):
> ("write-request-line"): Update for no scheme in some URIs.
>
> ("entity headers", "request headers"): Content-location and referer
> should also parse relative-URIs.
> ("response headers"): Location should not parse relative-URIs.
>
> * test-suite/tests/web-request.test ("example-1"): Expect URI-reference
> with no scheme.
> ---
> doc/ref/web.texi | 8 --
> module/web/http.scm | 47 ++++++-----
> module/web/uri.scm | 158
> ++++++++++++++++++++++++++++++++++---
> test-suite/tests/web-http.test | 54 ++++++++-----
> test-suite/tests/web-request.test | 5 +-
> test-suite/tests/web-uri.test | 66 +++++++++++++++-
> 6 files changed, 275 insertions(+), 63 deletions(-)
>
> diff --git a/doc/ref/web.texi b/doc/ref/web.texi
> index 0d41f9f..476151b 100644
> --- a/doc/ref/web.texi
> +++ b/doc/ref/web.texi
> @@ -190,14 +190,6 @@ since passwords do not belong in URIs, the RFC does not
> want to condone
> this practice, so it calls anything before the @code{@@} sign
> @dfn{userinfo}.
>
> -Properly speaking, a fragment is not part of a URI. For example, when a
> -web browser follows a link to @indicateurl{http://example.com/#foo}, it
> -sends a request for @indicateurl{http://example.com/}, then looks in the
> -resulting page for the fragment identified @code{foo} reference. A
> -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.
> -
> @example
> (use-modules (web uri))
> @end example
> diff --git a/module/web/http.scm b/module/web/http.scm
> index b5202b6..5c250d9 100644
> --- a/module/web/http.scm
> +++ b/module/web/http.scm
> @@ -1023,7 +1023,8 @@ symbol, like GET."
>
> (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."
> +not have to have a scheme or host name. The result is a URI-reference
> +object."
> (cond
> ((= start end)
> (bad-request "Missing Request-URI"))
> @@ -1033,10 +1034,10 @@ 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))
> - #:query (and q (substring str (1+ q) (or f end)))
> - #:fragment (and f (substring str (1+ f) end)))))
> + (build-uri-reference
> + #: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))
> (bad-request "Invalid URI: ~a" (substring str start end))))))
> @@ -1053,11 +1054,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 #\: port)))
> + (if (uri-host uri)
> + (begin
> + (display "//" port)
> (if (uri-userinfo uri)
> (begin
> (display (uri-userinfo uri) port)
> @@ -1171,20 +1178,22 @@ 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-reference-header! 'scheme-indent-function 1)
> +(define (declare-uri-reference-header! name)
> (declare-header! name
> (lambda (str)
> - (or ((@@ (web uri) string->uri*) str)
> - (bad-header-component 'uri str)))
> - uri?
> + (or (string->uri-reference str)
> + (bad-header-component 'uri-reference str)))
> + uri-reference?
> write-uri))
>
> ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
> @@ -1449,7 +1458,7 @@ treated specially, and is just returned as a plain
> string."
>
> ;; Content-Location = ( absoluteURI | relativeURI )
> ;;
> -(declare-relative-uri-header! "Content-Location")
> +(declare-uri-reference-header! "Content-Location")
>
> ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
> ;;
> @@ -1752,7 +1761,7 @@ treated specially, and is just returned as a plain
> string."
>
> ;; Referer = ( absoluteURI | relativeURI )
> ;;
> -(declare-relative-uri-header! "Referer")
> +(declare-uri-reference-header! "Referer")
>
> ;; TE = #( t-codings )
> ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
> @@ -1789,7 +1798,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 7fe0100..8a8e1d9 100644
> --- a/module/web/uri.scm
> +++ b/module/web/uri.scm
> @@ -40,11 +40,15 @@
> string->uri uri->string
> uri-decode uri-encode
> split-and-decode-uri-path
> - encode-and-join-uri-path))
> + encode-and-join-uri-path
> +
> + uri-reference? relative-ref? absolute-uri?
> + build-uri-reference build-relative-ref build-absolute-uri
> + string->uri-reference string->relative-ref string->absolute-uri))
>
> (define-record-type <uri>
> (make-uri scheme userinfo host port path query fragment)
> - uri?
> + uri-reference?
> (scheme uri-scheme)
> (userinfo uri-userinfo)
> (host uri-host)
> @@ -53,8 +57,51 @@
> (query uri-query)
> (fragment uri-fragment))
>
> +;;;
> +;;; Predicates.
> +;;;
> +;;; These are quick, and assume rigid validation at construction time.
> +
> +;;; RFC 3986, #3.
> +;;;
> +;;; URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
> +;;;
> +;;; hier-part = "//" authority path-abempty
> +;;; / path-absolute
> +;;; / path-rootless
> +;;; / path-empty
> +
> +(define (uri? obj)
> + (and (uri-reference? obj)
> + (uri-scheme obj)))
> +
> +;;; RFC 3986, #4.2.
> +;;;
> +;;; relative-ref = relative-part [ "?" query ] [ "#" fragment ]
> +;;;
> +;;; relative-part = "//" authority path-abempty
> +;;; / path-absolute
> +;;; / path-noscheme
> +;;; / path-empty
> +
> +(define (relative-ref? obj)
> + (and (uri-reference? obj)
> + (not (uri-scheme obj))))
> +
> +;;; RFC 3986, #4.3.
> +;;;
> +;;; absolute-URI = scheme ":" hier-part [ "?" query ]
> +
> (define (absolute-uri? obj)
> - (and (uri? obj) (uri-scheme obj) #t))
> + (and (uri-reference? obj)
> + (uri-scheme obj)
> + (not (uri-fragment obj))))
> +
> +
> +;;;
> +;;; Constructors.
> +;;;
> +;;; Disable validation at your own peril!
>
> (define (uri-error message . args)
> (throw 'uri-error message args))
> @@ -62,9 +109,13 @@
> (define (positive-exact-integer? port)
> (and (number? port) (exact? port) (integer? port) (positive? port)))
>
> -(define (validate-uri scheme userinfo host port path query fragment)
> +(define* (validate-uri-reference scheme userinfo host port path query
> fragment
> + #:key scheme? no-scheme? no-fragment?
> + (relative-part? (not scheme)))
> (cond
> - ((not (symbol? scheme))
> + ((and scheme no-scheme?)
> + (uri-error "Expected no scheme: ~s" scheme))
> + ((and (or scheme? 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"))
> @@ -76,9 +127,45 @@
> (uri-error "Expected string for userinfo: ~s" userinfo))
> ((not (string? path))
> (uri-error "Expected string for path: ~s" path))
> - ((and host (not (string-null? path))
> - (not (eqv? (string-ref path 0) #\/)))
> - (uri-error "Expected path of absolute URI to start with a /: ~a" path))))
> + ((and query (not (string? query)))
> + (uri-error "Expected string for query: ~s" query))
> + ((and fragment no-fragment?)
> + (uri-error "Expected no fragment: ~s" fragment))
> + ((and fragment (not (string? fragment)))
> + (uri-error "Expected string for fragment: ~s" fragment))
> + ;; Strict validation of allowed paths, based on other components.
> + ;; Refer to RFC 3986 for the details.
> + ((not (string-null? path))
> + (if host
> + (cond
> + ((not (eqv? (string-ref path 0) #\/))
> + (uri-error
> + "Expected absolute path starting with \"/\": ~a" path)))
> + (cond
> + ((string-prefix? "//" path)
> + (uri-error
> + "Expected path not starting with \"//\" (no host): ~a" path))
> + ((and relative-part?
> + (not (eqv? (string-ref path 0) #\/))
> + (let ((colon (string-index path #\:)))
> + (and colon (not (string-index path #\/ 0 colon)))))
> + (uri-error
> + "Expected relative path's first segment without \":\": ~a"
> + path)))))))
> +
> +(define (validate-uri scheme userinfo host port path query fragment)
> + (validate-uri-reference scheme userinfo host port path query fragment
> + #:scheme? #t))
> +
> +(define (validate-relative-ref scheme userinfo host port path query fragment)
> + (validate-uri-reference scheme userinfo host port path query fragment
> + #:no-scheme? #t
> + #:relative-part? #t))
> +
> +(define (validate-absolute-uri scheme userinfo host port path query fragment)
> + (validate-uri-reference scheme userinfo host port path query fragment
> + #:scheme? #t
> + #:no-fragment? #t))
>
> (define* (build-uri scheme #:key userinfo host port (path "") query fragment
> (validate? #t))
> @@ -91,6 +178,38 @@ is valid."
> (validate-uri scheme userinfo host port path query fragment))
> (make-uri scheme userinfo host port path query fragment))
>
> +(define* (build-uri-reference #:key scheme userinfo host port
> + (path "") query fragment
> + (validate? #t))
> + "Construct a URI-reference object. Fields are the same as for
> +build-uri except that SCHEME may also be #f."
> + (if validate?
> + (validate-uri-reference scheme userinfo host port path query fragment))
> + (make-uri scheme userinfo host port path query fragment))
> +
> +(define* (build-relative-ref #:key userinfo host port
> + (path "") query fragment
> + (validate? #t))
> + "Construct an absolute-URI object. Fields are the same as for
> +build-uri except there is no scheme."
> + (if validate?
> + (validate-relative-ref #f userinfo host port path query fragment))
> + (make-uri #f userinfo host port path query fragment))
> +
> +(define* (build-absolute-uri #:key scheme userinfo host port
> + (path "") query
> + (validate? #t))
> + "Construct an absolute-URI object. Fields are the same as for
> +build-uri except there is no fragment."
> + (if validate?
> + (validate-absolute-uri scheme userinfo host port path query #f))
> + (make-uri scheme userinfo host port path query #f))
> +
> +
> +;;;
> +;;; Converters.
> +;;;
> +
> ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC
> ;; 3490), and non-ASCII host names.
> ;;
> @@ -173,9 +292,7 @@ is valid."
> (define uri-regexp
> (make-regexp uri-pat))
>
> -(define (string->uri* string)
> - "Parse STRING into a URI object. Return #f if the string
> -could not be parsed."
> +(define (string->uri* string validate)
> (% (let ((m (regexp-exec uri-regexp string)))
> (if (not m) (abort))
> (let ((scheme (let ((str (match:substring m 2)))
> @@ -190,6 +307,7 @@ could not be parsed."
> (parse-authority authority abort)
> (values #f #f #f)))
> (lambda (userinfo host port)
> + (validate scheme userinfo host port path query fragment)
> (make-uri scheme userinfo host port path query fragment)))))
> (lambda (k)
> #f)))
> @@ -197,8 +315,22 @@ could not be parsed."
> (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)))
> + (string->uri* string validate-uri))
> +
> +(define (string->uri-reference string)
> + "Parse STRING into a URI-reference object. Return #f if the string
> +could not be parsed."
> + (string->uri* string validate-uri-reference))
> +
> +(define (string->relative-ref string)
> + "Parse STRING into a relative-ref object. Return #f if the string
> +could not be parsed."
> + (string->uri* string validate-relative-ref))
> +
> +(define (string->absolute-uri string)
> + "Parse STRING into an absolute-URI object. Return #f if the string
> +could not be parsed."
> + (string->uri* string validate-absolute-uri))
>
> (define *default-ports* (make-hash-table))
>
> diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
> index 2913724..b836926 100644
> --- a/test-suite/tests/web-http.test
> +++ b/test-suite/tests/web-http.test
> @@ -1,6 +1,6 @@
> ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8;
> -*-
> ;;;;
> -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
> +;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
> ;;;;
> ;;;; This library is free software; you can redistribute it and/or
> ;;;; modify it under the terms of the GNU Lesser General Public
> @@ -132,32 +132,33 @@
> (with-test-prefix "read-request-line"
> (pass-if-read-request-line "GET / HTTP/1.1"
> GET
> - (build-uri 'http
> - #:path "/")
> + (build-uri-reference
> + #:path "/")
> (1 . 1))
> (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html
> HTTP/1.1"
> GET
> - (build-uri 'http
> - #:host "www.w3.org"
> - #:path "/pub/WWW/TheProject.html")
> + (build-uri-reference
> + #:scheme 'http
> + #:host "www.w3.org"
> + #:path "/pub/WWW/TheProject.html")
> (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-reference
> + #: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"
> - #:query "foo=bar")
> + (build-uri-reference
> + #: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-reference
> + #: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,14 +171,14 @@
> ;; (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-reference
> + #: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"
> - #:query "foo=bar")
> + (build-uri-reference
> + #:path "/etc/hosts"
> + #:query "foo=bar")
> (1 . 1)))
>
> (with-test-prefix "read-response-line"
> @@ -252,6 +253,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-reference #:host "foo" #:path "/"))
> + (pass-if-parse content-location "/etc/foo"
> + (build-uri-reference #:path "/etc/foo"))
> + (pass-if-parse content-location "foo"
> + (build-uri-reference #: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))
> @@ -319,6 +326,14 @@
> (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-reference #:host "foo"
> + #:path "/bar"
> + #:query "baz"))
> + (pass-if-parse referer "/etc/foo"
> + (build-uri-reference #:path "/etc/foo"))
> + (pass-if-parse referer "foo"
> + (build-uri-reference #:path "foo"))
> (pass-if-parse te "trailers" '((trailers)))
> (pass-if-parse te "trailers,foo" '((trailers) (foo)))
> (pass-if-parse user-agent "guile" "guile"))
> @@ -333,6 +348,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..68721d3 100644
> --- a/test-suite/tests/web-request.test
> +++ b/test-suite/tests/web-request.test
> @@ -1,6 +1,6 @@
> ;;;; web-request.test --- HTTP requests -*- mode: scheme; coding:
> utf-8; -*-
> ;;;;
> -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
> +;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
> ;;;;
> ;;;; This library is free software; you can redistribute it and/or
> ;;;; modify it under the terms of the GNU Lesser General Public
> @@ -53,7 +53,8 @@ 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-reference #: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..21d8044 100644
> --- a/test-suite/tests/web-uri.test
> +++ b/test-suite/tests/web-uri.test
> @@ -1,6 +1,6 @@
> ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8;
> -*-
> ;;;;
> -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
> +;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation,
> Inc.
> ;;;;
> ;;;; This library is free software; you can redistribute it and/or
> ;;;; modify it under the terms of the GNU Lesser General Public
> @@ -27,7 +27,7 @@
>
>
> (define* (uri=? uri #:key scheme userinfo host port path query fragment)
> - (and (uri? uri)
> + (and (uri-reference? uri)
> (equal? (uri-scheme uri) scheme)
> (equal? (uri-userinfo uri) userinfo)
> (equal? (uri-host uri) host)
> @@ -123,6 +123,22 @@
> "Expected.*host"
> (build-uri 'http #:userinfo "foo")))
>
> +(with-test-prefix "build-uri-reference"
> + (pass-if "//host/etc/foo"
> + (uri=? (build-uri-reference #:host "host"
> + #:path "/etc/foo")
> + #:host "host"
> + #:path "/etc/foo"))
> +
> + (pass-if "/path/to/some/foo?query"
> + (uri=? (build-uri-reference #:path "/path/to/some/foo"
> + #:query "query")
> + #:path "/path/to/some/foo"
> + #:query "query"))
> +
> + (pass-if "nextdoc/foo"
> + (uri=? (build-uri-reference #:path "nextdoc/foo")
> + #:path "nextdoc/foo")))
>
> (with-test-prefix "string->uri"
> (pass-if "ftp:"
> @@ -212,6 +228,30 @@
> #:scheme 'file
> #:path "/etc/hosts")))
>
> +(with-test-prefix "string->uri-reference"
> + (pass-if "/"
> + (uri=? (string->uri-reference "/")
> + #:path "/"))
> +
> + (pass-if "/path/to/foo"
> + (uri=? (string->uri-reference "/path/to/foo")
> + #:path "/path/to/foo"))
> +
> + (pass-if "//example.org"
> + (uri=? (string->uri-reference "//example.org")
> + #:host "example.org"
> + #:path ""))
> +
> + (pass-if "//address@hidden/path/to/foo"
> + (uri=? (string->uri-reference "//address@hidden/path/to/foo")
> + #:userinfo "bar"
> + #:host "example.org"
> + #:path "/path/to/foo"))
> +
> + (pass-if "nextdoc/foo"
> + (uri=? (string->uri-reference "nextdoc/foo")
> + #:path "nextdoc/foo")))
> +
> (with-test-prefix "uri->string"
> (pass-if "ftp:"
> (equal? "ftp:"
> @@ -248,7 +288,27 @@
>
> (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-reference "/"))))
> +
> + (pass-if "/path/to/foo"
> + (equal? "/path/to/foo"
> + (uri->string (string->uri-reference "/path/to/foo"))))
> +
> + (pass-if "//example.org"
> + (equal? "//example.org"
> + (uri->string (string->uri-reference "//example.org"))))
> +
> + (pass-if "//address@hidden/path/to/foo"
> + (equal? "//address@hidden/path/to/foo"
> + (uri->string (string->uri-reference
> "//address@hidden/path/to/foo"))))
> +
> + (pass-if "nextdoc/foo"
> + (equal? "nextdoc/foo"
> + (uri->string (string->uri-reference "nextdoc/foo")))))
>
> (with-test-prefix "decode"
> (pass-if "foo%20bar"
- bug#12827: [PATCH] Tweak web modules, support relative URIs,
Andy Wingo <=