summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/web.texi60
-rw-r--r--module/web/http.scm104
-rw-r--r--module/web/response.scm18
-rw-r--r--test-suite/tests/web-http.test20
-rw-r--r--test-suite/tests/web-response.test24
5 files changed, 218 insertions, 8 deletions
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index a3d92ad8f..d4eec1021 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -37,6 +37,7 @@ back.
* URIs:: Universal Resource Identifiers.
* HTTP:: The Hyper-Text Transfer Protocol.
* HTTP Headers:: How Guile represents specific header values.
+* Transfer Codings:: HTTP Transfer Codings.
* Requests:: HTTP requests.
* Responses:: HTTP responses.
* Web Client:: Accessing web resources over HTTP.
@@ -1020,6 +1021,65 @@ A list of challenges to a user, indicating the need for authentication.
@end example
@end deftypevr
+@node Transfer Codings
+@subsection Transfer Codings
+
+HTTP 1.1 allows for various transfer codings to be applied to message
+bodies. These include various types of compression, and HTTP chunked
+encoding. Currently, only chunked encoding is supported by guile.
+
+Chunked coding is an optional coding that may be applied to message
+bodies, to allow messages whose length is not known beforehand to be
+returned. Such messages can be split into chunks, terminated by a final
+zero length chunk.
+
+In order to make dealing with encodings more simple, guile provides
+procedures to create ports that ``wrap'' existing ports, applying
+transformations transparently under the hood.
+
+@deffn {Scheme Procedure} make-chunked-input-port port [#:keep-alive?=#f]
+Returns a new port, that transparently reads and decodes chunk-encoded
+data from @var{port}. If no more chunk-encoded data is available, it
+returns the end-of-file object. When the port is closed, @var{port} will
+also be closed, unless @var{keep-alive?} is true.
+@end deffn
+
+@example
+(use-modules (ice-9 rdelim))
+
+(define s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
+(define p (make-chunked-input-port (open-input-string s)))
+(read-line s)
+@result{} "First line"
+(read-line s)
+@result{} "Second line"
+@end example
+
+@deffn {Scheme Procedure} make-chunked-output-port port [#:keep-alive?=#f]
+Returns a new port, which transparently encodes data as chunk-encoded
+before writing it to @var{port}. Whenever a write occurs on this port,
+it buffers it, until the port is flushed, at which point it writes a
+chunk containing all the data written so far. When the port is closed,
+the data remaining is written to @var{port}, as is the terminating zero
+chunk. It also causes @var{port} to be closed, unless @var{keep-alive?}
+is true.
+
+Note. Forcing a chunked output port when there is no data is buffered
+does not write a zero chunk, as this would cause the data to be
+interpreted incorrectly by the client.
+@end deffn
+
+@example
+(call-with-output-string
+ (lambda (out)
+ (define out* (make-chunked-output-port out #:keep-alive? #t))
+ (display "first chunk" out*)
+ (force-output out*)
+ (force-output out*) ; note this does not write a zero chunk
+ (display "second chunk" out*)
+ (close-port out*)))
+@result{} "b\r\nfirst chunk\r\nc\r\nsecond chunk\r\n0\r\n"
+@end example
@node Requests
@subsection HTTP Requests
diff --git a/module/web/http.scm b/module/web/http.scm
index d579c5267..9232b281e 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -34,6 +34,9 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 q)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:export (string->header
header->string
@@ -59,7 +62,10 @@
read-request-line
write-request-line
read-response-line
- write-response-line))
+ write-response-line
+
+ make-chunked-input-port
+ make-chunked-output-port))
;;; TODO
@@ -1799,3 +1805,99 @@ phrase\"."
;; WWW-Authenticate = 1#challenge
;;
(declare-challenge-list-header! "WWW-Authenticate")
+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+ (let* ((str (read-line port))
+ (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+ (char=? c #\return)))))
+ (size (string->number (if extension-start ; unnecessary?
+ (substring str 0 extension-start)
+ str)
+ 16)))
+ size))
+
+(define (read-chunk port)
+ (let ((size (read-chunk-header port)))
+ (read-chunk-body port size)))
+
+(define (read-chunk-body port size)
+ (let ((bv (get-bytevector-n port size)))
+ (get-u8 port) ; CR
+ (get-u8 port) ; LF
+ bv))
+
+(define* (make-chunked-input-port port #:key (keep-alive? #f))
+ "Returns a new port which translates HTTP chunked transfer encoded
+data from @var{port} into a non-encoded format. Returns eof when it has
+read the final chunk from @var{port}. This does not necessarily mean
+that there is no more data on @var{port}. When the returned port is
+closed it will also close @var{port}, unless the KEEP-ALIVE? is true."
+ (define (next-chunk)
+ (read-chunk port))
+ (define finished? #f)
+ (define (close)
+ (unless keep-alive?
+ (close-port port)))
+ (define buffer #vu8())
+ (define buffer-size 0)
+ (define buffer-pointer 0)
+ (define (read! bv idx to-read)
+ (define (loop to-read num-read)
+ (cond ((or finished? (zero? to-read))
+ num-read)
+ ((<= to-read (- buffer-size buffer-pointer))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ to-read)
+ (set! buffer-pointer (+ buffer-pointer to-read))
+ (loop 0 (+ num-read to-read)))
+ (else
+ (let ((n (- buffer-size buffer-pointer)))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ n)
+ (set! buffer (next-chunk))
+ (set! buffer-pointer 0)
+ (set! buffer-size (bytevector-length buffer))
+ (set! finished? (= buffer-size 0))
+ (loop (- to-read n)
+ (+ num-read n))))))
+ (loop to-read 0))
+ (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #:key (keep-alive? #f))
+ "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to @var{port}. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close @var{port}, unless
+KEEP-ALIVE? is true."
+ (define (q-for-each f q)
+ (while (not (q-empty? q))
+ (f (deq! q))))
+ (define queue (make-q))
+ (define (put-char c)
+ (enq! queue c))
+ (define (put-string s)
+ (string-for-each (lambda (c) (enq! queue c))
+ s))
+ (define (flush)
+ ;; It is important that we do _not_ write a chunk if the queue is
+ ;; empty, since it will be treated as the final chunk.
+ (unless (q-empty? queue)
+ (let ((len (q-length queue)))
+ (display (number->string len 16) port)
+ (display "\r\n" port)
+ (q-for-each (lambda (elem) (write-char elem port))
+ queue)
+ (display "\r\n" port))))
+ (define (close)
+ (flush)
+ (display "0\r\n" port)
+ (force-output port)
+ (unless keep-alive?
+ (close-port port)))
+ (make-soft-port (vector put-char put-string flush #f close) "w"))
diff --git a/module/web/response.scm b/module/web/response.scm
index 07e124539..6eba69d8d 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -227,13 +227,17 @@ This is true for some response types, like those with code 304."
(define (read-response-body r)
"Reads the response body from @var{r}, as a bytevector. Returns
@code{#f} if there was no response body."
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((bv (get-bytevector-n (response-port r) nbytes)))
- (if (= (bytevector-length bv) nbytes)
- bv
- (bad-response "EOF while reading response body: ~a bytes of ~a"
- (bytevector-length bv) nbytes))))))
+ (if (member '(chunked) (response-transfer-encoding r))
+ (let ((chunk-port (make-chunked-input-port (response-port r)
+ #:keep-alive? #t)))
+ (get-bytevector-all chunk-port))
+ (let ((nbytes (response-content-length r)))
+ (and nbytes
+ (let ((bv (get-bytevector-n (response-port r) nbytes)))
+ (if (= (bytevector-length bv) nbytes)
+ bv
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ (bytevector-length bv) nbytes)))))))
(define (write-response-body r bv)
"Write @var{bv}, a bytevector, to the port corresponding to the HTTP
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 79845653e..97f55594a 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -20,6 +20,7 @@
(define-module (test-suite web-http)
#:use-module (web uri)
#:use-module (web http)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 regex)
#:use-module (ice-9 control)
#:use-module (srfi srfi-19)
@@ -232,3 +233,22 @@
(pass-if-parse vary "foo, bar" '(foo bar))
(pass-if-parse www-authenticate "Basic realm=\"guile\""
'((basic (realm . "guile")))))
+
+(with-test-prefix "chunked encoding"
+ (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
+ (p (make-chunked-input-port (open-input-string s))))
+ (pass-if (equal? "First line\n Second line"
+ (get-string-all p)))
+ (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n")))))
+ (pass-if
+ (equal? (call-with-output-string
+ (lambda (out-raw)
+ (let ((out-chunked (make-chunked-output-port out-raw
+ #:keep-alive? #t)))
+ (display "First chunk" out-chunked)
+ (force-output out-chunked)
+ (display "Second chunk" out-chunked)
+ (force-output out-chunked)
+ (display "Third chunk" out-chunked)
+ (close-port out-chunked))))
+ "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n")))
diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
index a21a70207..ddd55a750 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -40,6 +40,19 @@ Content-Type: text/html; charset=utf-8\r
\r
abcdefghijklmnopqrstuvwxyz0123456789")
+(define example-2
+ "HTTP/1.1 200 OK\r
+Transfer-Encoding: chunked\r
+Content-Type: text/plain
+\r
+1c\r
+Lorem ipsum dolor sit amet, \r
+1d\r
+consectetur adipisicing elit,\r
+43\r
+ sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\r
+0\r\n")
+
(define (responses-equal? r1 body1 r2 body2)
(and (equal? (response-version r1) (response-version r2))
(equal? (response-code r1) (response-code r2))
@@ -100,3 +113,14 @@ abcdefghijklmnopqrstuvwxyz0123456789")
(pass-if "by accessor"
(equal? (response-content-encoding r) '(gzip)))))
+
+(with-test-prefix "example-2"
+ (let* ((r (read-response (open-input-string example-2)))
+ (b (read-response-body r)))
+ (pass-if (equal? '((chunked))
+ (response-transfer-encoding r)))
+ (pass-if (equal? b
+ (string->utf8
+ (string-append
+ "Lorem ipsum dolor sit amet, consectetur adipisicing elit,"
+ " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua."))))))