summaryrefslogtreecommitdiff
path: root/module/web/http.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-10-15 11:49:41 +0200
committerAndy Wingo <wingo@pobox.com>2014-11-01 15:36:56 +0100
commit18c44b29e4438976dac86a3cb53a273dde42e294 (patch)
tree0decd8153038f4775a01776c27ebc724eb94aed3 /module/web/http.scm
parent7f2c824551aa848b359ef6b79c1d5e15d367eb8a (diff)
downloadguile-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/web/http.scm')
-rw-r--r--module/web/http.scm56
1 files changed, 29 insertions, 27 deletions
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
;;