[PATCH] Make HTTP header symbols case-insensitive

[Skyler]

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