The web modules contain logic for operating on headers, including logic
to convert Scheme data to header values, validate the values of
well-known headers, and automatically add missing headers. When working
with headers internally, they are stored as lowercase symbols as is
idiomatic for Scheme code. When writing out the requests, the headers
are converted to title-case, as is idiomatic to HTTP (although HTTP
header names are technically defined to be case-insensitive, unlike
Scheme symbols).
This can cause issues if titlecase symbols are used in the header lists
of functions such as http-request from the (web client) module. In this
case, the headers will not be recognized as well-defined headers, and
they will be validated with the generic validators instead of the
specific ones.
This commit converts header symbols to be all lowercase in the
build-request and build-response functions, to make sure that the system
handles the headers consistently.
---
doc/ref/web.texi | 4 ++++
module/web/http.scm | 8 ++++++++
module/web/request.scm | 9 +++++----
module/web/response.scm | 27 ++++++++++++++-------------
4 files changed, 31 insertions(+), 17 deletions(-)
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 607c855..4572b5a 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -471,6 +471,10 @@ Return a true value if @var{val} is a valid Scheme value
for the header
with name @var{sym}, or @code{#f} otherwise.
@end deffn
+@deffn {Scheme Procedure} canonicalize-headers headers
+Ensure that the headers are in a canonical Scheme format, in particular
+this converts all header names to lowercase.
+
Now that we have a generic interface for reading and writing headers, we
do just that.
diff --git a/module/web/http.scm b/module/web/http.scm
index 24a4312..9b241dc 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -40,6 +40,7 @@
#:use-module (web uri)
#:export (string->header
header->string
+ canonicalize-headers
declare-header!
declare-opaque-header!
@@ -80,6 +81,13 @@
(define (put-non-negative-integer port i)
(put-string port (number->string i)))
+(define (canonicalize-headers headers)
+ "Ensure that the symbolic header name is in lowercase."
+ (map (lambda (header)
+ (cons (string->symbol (string-downcase (symbol->string (car header))))
+ (cdr header)))
+ headers))
+
(define (string->header name)
"Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
diff --git a/module/web/request.scm b/module/web/request.scm
index ff4b944..c7366da 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -162,7 +162,8 @@
(validate-headers? #t))
"Construct an HTTP request object. If VALIDATE-HEADERS? is true,
the headers are each run through their respective validators."
- (let ((needs-host? (and (equal? version '(1 . 1))
+ (let ((canonicalized-headers (canonicalize-headers headers))
+ (needs-host? (and (equal? version '(1 . 1))
(not (assq-ref headers 'host)))))
(cond
((not (and (pair? version)
@@ -180,12 +181,12 @@ the headers are each run through their respective
validators."
uri))
(else
(if validate-headers?
- (validate-headers headers))))
+ (validate-headers canonicalized-headers))))
(make-request method uri version
(if needs-host?
(acons 'host (cons (uri-host uri) (uri-port uri))
- headers)
- headers)
+ canonicalized-headers)
+ canonicalized-headers)
meta port)))
(define* (read-request port #:optional (meta '()))
diff --git a/module/web/response.scm b/module/web/response.scm
index 4ac4d74..9cf9dbd 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -111,19 +111,20 @@
(headers '()) port (validate-headers? #t))
"Construct an HTTP response object. If VALIDATE-HEADERS? is true,
the headers are each run through their respective validators."
- (cond
- ((not (and (pair? version)
- (non-negative-integer? (car version))
- (non-negative-integer? (cdr version))))
- (bad-response "Bad version: ~a" version))
- ((not (and (non-negative-integer? code) (< code 600)))
- (bad-response "Bad code: ~a" code))
- ((and reason-phrase (not (string? reason-phrase)))
- (bad-response "Bad reason phrase" reason-phrase))
- (else
- (if validate-headers?
- (validate-headers headers))))
- (make-response version code reason-phrase headers port))
+ (let ((canonicalized-headers (canonicalize-headers headers)))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-response "Bad version: ~a" version))
+ ((not (and (non-negative-integer? code) (< code 600)))
+ (bad-response "Bad code: ~a" code))
+ ((and reason-phrase (not (string? reason-phrase)))
+ (bad-response "Bad reason phrase" reason-phrase))
+ (else
+ (if validate-headers?
+ (validate-headers canonicalized-headers))))
+ (make-response version code reason-phrase canonicalized-headers port)))
(define *reason-phrases*
'((100 . "Continue")
base-commit: f31819b6b179429a617c8bd881dbb61219823e39
--
2.41.0
