diff --git a/module/web/http.scm b/module/web/http.scm index f8dba30b5..216fddd3e 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1182,21 +1182,15 @@ treated specially, and is just returned as a plain string." (define (declare-uri-header! name) (declare-header! name (lambda (str) (or (string->uri str) (bad-header-component 'uri str))) - uri? + (@@ (web uri) absolute-uri?) write-uri)) ;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1) (define (declare-relative-uri-header! name) (declare-header! name (lambda (str) - ;; XXX: Attempt to build an absolute URI, and fall back to a URI - ;; with no scheme to represent a relative URI. - ;; See for ideas to fully support - ;; relative URIs (aka. "URI references"). - (or (string->uri str) ; absolute URI - (build-uri #f ; relative URI - #:path str - #:validate? #f))) + (or ((@@ (web uri) string->uri*) str) + (bad-header-component 'uri str))) uri? write-uri)) diff --git a/module/web/uri.scm b/module/web/uri.scm index 6ff00763c..b688ea8cb 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -53,6 +53,9 @@ (query uri-query) (fragment uri-fragment)) +(define (absolute-uri? x) + (and (uri? x) (uri-scheme x) #t)) + (define (uri-error message . args) (throw 'uri-error message args)) @@ -165,21 +168,21 @@ is valid." (define fragment-pat ".*") (define uri-pat - (format #f "^(~a):(//~a)?(~a)(\\?(~a))?(#(~a))?$" + (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$" scheme-pat authority-pat path-pat query-pat fragment-pat)) (define uri-regexp (make-regexp uri-pat)) -(define (string->uri string) +(define (string->uri* string) "Parse 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 (string->symbol - (string-downcase (match:substring m 1)))) - (authority (match:substring m 2)) - (path (match:substring m 3)) - (query (match:substring m 5)) + (let ((scheme (let ((str (match:substring m 2))) + (and str (string->symbol (string-downcase str))))) + (authority (match:substring m 3)) + (path (match:substring m 4)) + (query (match:substring m 6)) (fragment (match:substring m 7))) (call-with-values (lambda () @@ -191,6 +194,12 @@ could not be parsed." (lambda (k) #f))) +(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))) + (define *default-ports* (make-hash-table)) (define (declare-default-port! scheme port) @@ -208,8 +217,7 @@ could not be parsed." "Serialize URI to a string. If the URI has a port that is the default port for its scheme, the port is not included in the serialization." - (let* ((scheme-str (string-append - (symbol->string (uri-scheme uri)) ":")) + (let* ((scheme (uri-scheme uri)) (userinfo (uri-userinfo uri)) (host (uri-host uri)) (port (uri-port uri)) @@ -217,7 +225,9 @@ serialization." (query (uri-query uri)) (fragment (uri-fragment uri))) (string-append - scheme-str + (if scheme + (string-append (symbol->string scheme) ":") + "") (if host (string-append "//" (if userinfo (string-append userinfo "@")