From 26655a2ae8a2864ea867ed5240eff5d0bb916a49 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig 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 = ;; @@ -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 (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 "//bar@example.org/path/to/foo" + (uri=? (string->uri-reference "//bar@example.org/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 "//bar@example.org/path/to/foo" + (equal? "//bar@example.org/path/to/foo" + (uri->string (string->uri-reference "//bar@example.org/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" -- 1.7.10.4