mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Merge from stable-2.2

Browse source
This commit is contained in:
Andy Wingo 2019-08-02 15:21:34 +02:00
commit 160a5c89bf
2 changed files with 34 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/web/http.scm
View file

@ -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))))

11
test-suite/tests/web-http.test
View file

@ -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))