[Guile-commits] 01/01: web: Add support for HTTP header continuation lines.

[Mark H. Weaver]

mhw pushed a commit to branch stable-2.2
in repository guile.

commit 73cde5ed7218a090ecee888870908af5445796f0
Author: Mark H Weaver <address@hidden>
Date:   Tue Jun 18 08:26:00 2019 -0400

    web: Add support for HTTP header continuation lines.
    
    * module/web/http.scm (spaces-and-tabs, space-or-tab?): New variables.
    (read-header-line): After reading a header, if a space or tab follows,
    read the continuation lines and join them.
    * test-suite/tests/web-http.test: Add test.
---
 module/web/http.scm            | 31 ++++++++++++++++++++++++-------
 test-suite/tests/web-http.test | 11 ++++++++++-
 2 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index de61c94..f1ca733 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
-;; Copyright (C)  2010-2017 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2017, 2019 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -152,18 +152,35 @@ The default writer will call ‘put-string’."
         (lambda (val port)
           (put-string port val)))))
 
+(define spaces-and-tabs
+  (char-set #\space #\tab))
+
+(define (space-or-tab? c)
+  (case c
+    ((#\space #\tab) #t)
+    (else #f)))
+
 (define (read-header-line port)
-  "Read an HTTP header line and return it without its final CRLF or LF.
-Raise a 'bad-header' exception if the line does not end in CRLF or LF,
-or if EOF is reached."
+  "Read an HTTP header line, including any continuation lines, and
+return the combined string without its final CRLF or LF.  Raise a
+'bad-header' exception if the line does not end in CRLF or LF, or if EOF
+is reached."
   (match (%read-line port)
     (((? string? line) . #\newline)
      ;; '%read-line' does not consider #\return a delimiter; so if it's
      ;; there, remove it.  We are more tolerant than the RFC in that we
      ;; tolerate LF-only endings.
-     (if (string-suffix? "\r" line)
-         (string-drop-right line 1)
-         line))
+     (let ((line (if (string-suffix? "\r" line)
+                     (string-drop-right line 1)
+                     line)))
+       ;; If the next character is a space or tab, then there's at least
+       ;; one continuation line.  Read the continuation lines by calling
+       ;; 'read-header-line' recursively, and append them to this header
+       ;; line, folding the leading spaces and tabs to a single space.
+       (if (space-or-tab? (lookahead-char port))
+           (string-append line " " (string-trim (read-header-line port)
+                                                spaces-and-tabs))
+           line)))
     ((line . _)                                ;EOF or missing delimiter
      (bad-header 'read-header-line line))))
 
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 6337734..c1cf088 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -1,6 +1,6 @@
 ;;;; web-http.test --- HTTP library        -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010-2011, 2014-2017 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010-2011, 2014-2017, 2019 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -242,6 +242,15 @@
   (pass-if-round-trip "Cache-Control: acme-cache-extension=100 quux\r\n")
   (pass-if-round-trip "Cache-Control: acme-cache-extension=\"100, quux\"\r\n")
 
+  (let ((str "Cache-Control: acme-cache-extension=\"100,\r\n\t foo,\r\n  
quux\"\r\n")
+        (val '(cache-control . ((acme-cache-extension . "100, foo, quux")))))
+    (pass-if-equal "continuation lines"
+        val
+      (call-with-values (lambda ()
+                          (read-header (open-input-string str)))
+        (lambda (sym val)
+          (cons sym val)))))
+
   (pass-if-parse connection "close" '(close))
   (pass-if-parse connection "Content-Encoding" '(content-encoding))