From 18c44b29e4438976dac86a3cb53a273dde42e294 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Oct 2014 11:49:41 +0200 Subject: 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. --- module/web/request.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'module/web/request.scm') 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) -- cgit v1.2.3