mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 04:00:19 +02:00
Code Activity

http: Accept empty reason phrases.

Browse source 
Fixes <http://bugs.gnu.org/22273>.
Reported by Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de>.

* module/web/http.scm (read-header-line): New procedure.
(read-response-line): Use it instead of 'read-line*'.
* test-suite/tests/web-http.test ("read-response-line"): Add test.
This commit is contained in:
Ludovic Courtès 2016-01-06 14:56:00 +01:00 • committed by Andy Wingo
parent 3829047ec7
commit f53145d41c
2 changed files with 25 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/web/http.scm
View file

@ -144,7 +144,22 @@ The default writer is ‘display’."
(header-decl-writer decl) (header-decl-writer decl)
display))) display)))
(define (read-line* port) (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."
(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))
((line . _) ;EOF or missing delimiter
(bad-header 'read-header-line line))))
(define* (read-line* port)
(let* ((pair (%read-line port)) (let* ((pair (%read-line port))
(line (car pair)) (line (car pair))
(delim (cdr pair))) (delim (cdr pair)))
@ -1155,10 +1170,10 @@ three values: the method, the URI, and the version."
(display "\r\n" port)) (display "\r\n" port))
(define (read-response-line port) (define (read-response-line port)
"Read the first line of an HTTP response from PORT, returning "Read the first line of an HTTP response from PORT, returning three
three values: the HTTP version, the response code, and the \"reason values: the HTTP version, the response code, and the (possibly empty)
phrase\"." \"reason phrase\"."
(let* ((line (read-line* port)) (let* ((line (read-header-line port))
(d0 (string-index line char-set:whitespace)) ; "delimiter zero" (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
(d1 (and d0 (string-index line char-set:whitespace (d1 (and d0 (string-index line char-set:whitespace
(skip-whitespace line d0))))) (skip-whitespace line d0)))))

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

@ -194,7 +194,11 @@
(pass-if-read-response-line "HTTP/1.0 404 Not Found" (pass-if-read-response-line "HTTP/1.0 404 Not Found"
(1 . 0) 404 "Not Found") (1 . 0) 404 "Not Found")
(pass-if-read-response-line "HTTP/1.1 200 OK" (pass-if-read-response-line "HTTP/1.1 200 OK"
(1 . 1) 200 "OK")) (1 . 1) 200 "OK")
;; Empty reason phrases are valid; see <http://bugs.gnu.org/22273>.
(pass-if-read-response-line "HTTP/1.1 302 "
(1 . 1) 302 ""))
(with-test-prefix "write-response-line" (with-test-prefix "write-response-line"
(pass-if-write-response-line "HTTP/1.0 404 Not Found" (pass-if-write-response-line "HTTP/1.0 404 Not Found"