diff options
author | Andy Wingo <wingo@pobox.com> | 2014-10-15 11:49:41 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-11-01 15:36:56 +0100 |
commit | 18c44b29e4438976dac86a3cb53a273dde42e294 (patch) | |
tree | 0decd8153038f4775a01776c27ebc724eb94aed3 /module | |
parent | 7f2c824551aa848b359ef6b79c1d5e15d367eb8a (diff) | |
download | guile-18c44b29e4438976dac86a3cb53a273dde42e294.tar.gz |
web: Location header is URI-reference; better URI-reference support
* module/web/uri.scm (validate-uri): Add reference? keyword argument,
for validating references.
(build-uri): Clarify comments to indicate that the result is an
absolute URI.
(build-uri-reference): New interface, to build URI-references.
(string->uri-reference): Rename from string->uri*. Fix fragment
parsing to not include the #.
(string->uri): Adapt to string->uri-reference name change.
* module/web/request.scm (request-absolute-uri): Add default-scheme
optional argument. Use it if the request-uri has no scheme, or
error.
* module/web/http.scm (write-uri): Reflow to use "when". Fix writing of
URI-reference instances.
(declare-uri-reference-header!): Rename from
declare-relative-uri-header!. Use string->uri-reference.
("Location"): Declare as a URI-reference header, as per RFC 7231.
* module/web/client.scm (open-socket-for-uri): Handle the case in which
there is no URI scheme.
* test-suite/tests/web-http.test:
* test-suite/tests/web-uri.test: Add tests.
Diffstat (limited to 'module')
-rw-r--r-- | module/web/client.scm | 3 | ||||
-rw-r--r-- | module/web/http.scm | 56 | ||||
-rw-r--r-- | module/web/request.scm | 8 | ||||
-rw-r--r-- | module/web/uri.scm | 48 |
4 files changed, 70 insertions, 45 deletions
diff --git a/module/web/client.scm b/module/web/client.scm index 070b0c3d1..11fee352d 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -74,7 +74,8 @@ (delete-duplicates (getaddrinfo (uri-host uri) (cond (port => number->string) - (else (symbol->string (uri-scheme uri)))) + ((uri-scheme uri) => symbol->string) + (else (error "Not an absolute URI" uri))) (if port AI_NUMERICSERV 0)) diff --git a/module/web/http.scm b/module/web/http.scm index aa75142fc..a157cf021 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1090,20 +1090,19 @@ three values: the method, the URI, and the version." (bad-request "Bad Request-Line: ~s" line)))) (define (write-uri uri port) - (if (uri-host uri) - (begin - (display (uri-scheme uri) port) - (display "://" port) - (if (uri-userinfo uri) - (begin - (display (uri-userinfo uri) port) - (display #\@ port))) - (display (uri-host uri) port) - (let ((p (uri-port uri))) - (if (and p (not (eqv? p 80))) - (begin - (display #\: port) - (display p port)))))) + (when (uri-host uri) + (when (uri-scheme uri) + (display (uri-scheme uri) port) + (display #\: port)) + (display "//" port) + (when (uri-userinfo uri) + (display (uri-userinfo uri) port) + (display #\@ port)) + (display (uri-host uri) port) + (let ((p (uri-port uri))) + (when (and p (not (eqv? p 80))) + (display #\: port) + (display p port)))) (let* ((path (uri-path uri)) (len (string-length path))) (cond @@ -1113,10 +1112,9 @@ three values: the method, the URI, and the version." (bad-request "Empty path and no host for URI: ~s" uri)) (else (display path port)))) - (if (uri-query uri) - (begin - (display #\? port) - (display (uri-query uri) port)))) + (when (uri-query uri) + (display #\? port) + (display (uri-query uri) port))) (define (write-request-line method uri version port) "Write the first line of an HTTP request to PORT." @@ -1226,11 +1224,11 @@ treated specially, and is just returned as a plain string." (@@ (web uri) 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) + (or (string->uri-reference str) (bad-header-component 'uri str))) uri? write-uri)) @@ -1519,9 +1517,9 @@ treated specially, and is just returned as a plain string." ;; (declare-integer-header! "Content-Length") -;; Content-Location = ( absoluteURI | relativeURI ) +;; Content-Location = URI-reference ;; -(declare-relative-uri-header! "Content-Location") +(declare-uri-reference-header! "Content-Location") ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> ;; @@ -1822,9 +1820,9 @@ treated specially, and is just returned as a plain string." (display (cdr pair) port))) ","))) -;; Referer = ( absoluteURI | relativeURI ) +;; Referer = URI-reference ;; -(declare-relative-uri-header! "Referer") +(declare-uri-reference-header! "Referer") ;; TE = #( t-codings ) ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) @@ -1859,9 +1857,13 @@ treated specially, and is just returned as a plain string." entity-tag? write-entity-tag) -;; Location = absoluteURI +;; Location = URI-reference +;; +;; In RFC 2616, Location was specified as being an absolute URI. This +;; was changed in RFC 7231 to permit URI references generally, which +;; matches web reality. ;; -(declare-uri-header! "Location") +(declare-uri-reference-header! "Location") ;; Proxy-Authenticate = 1#challenge ;; diff --git a/module/web/request.scm b/module/web/request.scm index 7ced076fa..0a206cf35 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -300,7 +300,8 @@ request R." (define-request-accessor user-agent #f) ;; Misc accessors -(define* (request-absolute-uri r #:optional default-host default-port) +(define* (request-absolute-uri r #:optional default-host default-port + default-scheme) "A helper routine to determine the absolute URI of a request, using the ‘host’ header and the default host and port." (let ((uri (request-uri r))) @@ -313,7 +314,10 @@ request R." (bad-request "URI not absolute, no Host header, and no default: ~s" uri))))) - (build-uri (uri-scheme uri) + (build-uri (or (uri-scheme uri) + default-scheme + (bad-request "URI not absolute and no default-port" + uri)) #:host (car host) #:port (cdr host) #:path (uri-path uri) diff --git a/module/web/uri.scm b/module/web/uri.scm index 3ab820d14..e1c8b3998 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -1,6 +1,6 @@ ;;;; (web uri) --- URI manipulation tools ;;;; -;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014 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 @@ -36,8 +36,10 @@ uri-path uri-query uri-fragment build-uri + build-uri-reference declare-default-port! - string->uri uri->string + string->uri string->uri-reference + uri->string uri-decode uri-encode split-and-decode-uri-path encode-and-join-uri-path)) @@ -62,9 +64,10 @@ (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 scheme userinfo host port path query fragment + #:key reference?) (cond - ((not (symbol? scheme)) + ((and (not reference?) (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")) @@ -82,15 +85,26 @@ (define* (build-uri 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 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 object is a valid absolute URI." (if validate? (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 object. SCHEME should be a symbol or ‘#f’, 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 a valid URI +reference (either an absolute URI or a relative reference)." + (if validate? + (validate-uri scheme userinfo host port path query fragment + #:reference? #t)) + (make-uri scheme userinfo host port path query fragment)) + ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC ;; 3490), and non-ASCII host names. ;; @@ -156,6 +170,10 @@ is valid." ;;; / path-absolute ;;; / path-rootless ;;; / path-empty +;;; +;;; A URI-reference is the same as URI, but where the scheme is +;;; optional. If the scheme is not present, its colon isn't present +;;; either. (define scheme-pat "[a-zA-Z][a-zA-Z0-9+.-]*") @@ -173,9 +191,9 @@ 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-reference string) + "Parse the URI reference written as 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 (let ((str (match:substring m 2))) @@ -183,7 +201,7 @@ could not be parsed." (authority (match:substring m 3)) (path (match:substring m 4)) (query (match:substring m 6)) - (fragment (match:substring m 7))) + (fragment (match:substring m 8))) (call-with-values (lambda () (if authority @@ -195,9 +213,9 @@ could not be parsed." #f))) (define (string->uri string) - "Parse STRING into a URI object. Return ‘#f’ if the string + "Parse STRING into an absolute URI object. Return ‘#f’ if the string could not be parsed." - (let ((uri (string->uri* string))) + (let ((uri (string->uri-reference string))) (and uri (uri-scheme uri) uri))) (define *default-ports* (make-hash-table)) |