summaryrefslogtreecommitdiff
path: root/module/web
diff options
context:
space:
mode:
authorDaniel Hartwig <mandyke@gmail.com>2012-11-27 16:48:41 +0800
committerLudovic Courtès <ludo@gnu.org>2012-11-27 22:41:33 +0100
commit4e81e9d9a37ee958bf4b9a636a8f106f1241f1ce (patch)
treedbfe6f4d2475b365605499f12d2c955b5a76a3b9 /module/web
parent261af76005f0e31f570bed201a2ef2a43cdd6e11 (diff)
downloadguile-4e81e9d9a37ee958bf4b9a636a8f106f1241f1ce.tar.gz
web client: correctly handle uri-query, etc. in relative URI headers
* module/web/uri.scm (uri-pat): Make scheme part optional. (string->uri*): New private procedure to also parse relative URIs. * module/web/http.scm (declare-relative-uri-header!): Use that.
Diffstat (limited to 'module/web')
-rw-r--r--module/web/http.scm12
-rw-r--r--module/web/uri.scm30
2 files changed, 23 insertions, 19 deletions
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 <http://bugs.gnu.org/12827> 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 "@")