From 89dba22c5449567f0965c6a9ccdf50e33b6df7d5 Mon Sep 17 00:00:00 2001 From: Eitarow Fukamachi Date: Tue, 16 Aug 2016 12:13:00 +0900 Subject: [PATCH 1/2] Add tests for response headers (ref #22). --- src/backend/usocket.lisp | 63 ++++++++++++++++++++++++++++------------ t/dexador.lisp | 10 ++++--- 2 files changed, 51 insertions(+), 22 deletions(-) diff --git a/src/backend/usocket.lisp b/src/backend/usocket.lisp index 8e1bfee..7b62033 100644 --- a/src/backend/usocket.lisp +++ b/src/backend/usocket.lisp @@ -30,6 +30,7 @@ :fast-write-byte) (:import-from :chunga :chunked-stream-input-chunking-p + :chunked-stream-output-chunking-p :make-chunked-stream) (:import-from :trivial-mimes :mime) @@ -416,6 +417,14 @@ (reusing-stream-p (not (null stream))) (stream (or stream (make-new-connection uri))) + (content-length + (assoc :content-length headers :test #'string-equal)) + (transfer-encoding + (assoc :transfer-encoding headers :test #'string-equal)) + (chunkedp (or (and transfer-encoding + (equalp (cdr transfer-encoding) "chunked")) + (and content-length + (null (cdr content-length))))) (first-line-data (with-fast-output (buffer) (write-first-line method uri version buffer))) @@ -448,26 +457,36 @@ (cond (multipart-p (write-header* :content-type (format nil "multipart/form-data; boundary=~A" boundary)) - (write-header* :content-length - (multipart-content-length content boundary))) + (unless chunkedp + (write-header* :content-length + (multipart-content-length content boundary)))) (form-urlencoded-p (write-header* :content-type "application/x-www-form-urlencoded") - (write-header* :content-length (length (the string content)))) + (unless chunkedp + (write-header* :content-length (length (the string content))))) (t (etypecase content (null) (string (write-header* :content-type "text/plain") - (write-header* :content-length (length (the (simple-array (unsigned-byte 8) *) (babel:string-to-octets content))))) + (unless chunkedp + (write-header* :content-length (length (the (simple-array (unsigned-byte 8) *) (babel:string-to-octets content)))))) ((array (unsigned-byte 8) *) (write-header* :content-type "text/plain") - (write-header* :content-length (length content))) + (unless chunkedp + (write-header* :content-length (length content)))) (pathname (write-header* :content-type (mimes:mime content)) - (if-let ((content-length (assoc :content-length headers :test #'string-equal))) - (write-header :content-length (cdr content-length)) - (with-open-file (in content) - (write-header :content-length (file-length in)))))))) + (unless chunkedp + (if-let ((content-length (assoc :content-length headers :test #'string-equal))) + (write-header :content-length (cdr content-length)) + (with-open-file (in content) + (write-header :content-length (file-length in))))))))) + + ;; Transfer-Encoding: chunked + (when (and chunkedp + (not transfer-encoding)) + (write-header* :transfer-encoding "chunked")) ;; Custom headers (loop for (name . value) in headers @@ -500,15 +519,23 @@ ;; Sending the content (when content - (etypecase content - (string (write-sequence (babel:string-to-octets content) stream)) - ((array (unsigned-byte 8) *) - (write-sequence content stream)) - (pathname (with-open-file (in content :element-type '(unsigned-byte 8)) - (copy-stream in stream))) - (cons - (write-multipart-content content boundary stream))) - (with-retrying (force-output stream))) + (let ((stream (if chunkedp + (chunga:make-chunked-stream stream) + stream))) + (when chunkedp + (setf (chunga:chunked-stream-output-chunking-p stream) t)) + (etypecase content + (string + (write-sequence (babel:string-to-octets content) stream)) + ((array (unsigned-byte 8) *) + (write-sequence content stream)) + (pathname (with-open-file (in content :element-type '(unsigned-byte 8)) + (copy-stream in stream))) + (cons + (write-multipart-content content boundary stream))) + (when chunkedp + (setf (chunga:chunked-stream-output-chunking-p stream) nil)) + (with-retrying (finish-output stream)))) start-reading (multiple-value-bind (http body response-headers-data transfer-encoding-p) diff --git a/t/dexador.lisp b/t/dexador.lisp index c060849..f198d72 100644 --- a/t/dexador.lisp +++ b/t/dexador.lisp @@ -176,8 +176,8 @@ body: \"Within a couple weeks of learning Lisp I found programming in any other (subtest-app "HTTP request failed" (lambda (env) (if (string= (getf env :path-info) "/404") - '(404 () ("Not Found")) - '(500 () ("Internal Server Error")))) + '(404 (:x-foo 0) ("Not Found")) + '(500 (:x-bar 1) ("Internal Server Error")))) (handler-case (progn (dex:get (localhost)) @@ -187,7 +187,8 @@ body: \"Within a couple weeks of learning Lisp I found programming in any other (is (dex:response-status e) 500 "response status is 500") (is (dex:response-body e) "Internal Server Error" - "response body is \"Internal Server Error\""))) + "response body is \"Internal Server Error\"") + (is (gethash "x-bar" (dex:response-headers e)) 1))) (handler-case (progn (dex:get (localhost "/404")) @@ -197,7 +198,8 @@ body: \"Within a couple weeks of learning Lisp I found programming in any other (is (dex:response-status e) 404 "response status is 404") (is (dex:response-body e) "Not Found" - "response body is \"Not Found\"")))) + "response body is \"Not Found\"") + (is (gethash "x-foo" (dex:response-headers e)) 0)))) (subtest-app "Using cookies" (lambda (env) From 4654304bb2dde6b508a15bf8cc757856c825a81a Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Fri, 2 Sep 2016 17:19:35 +0900 Subject: [PATCH 2/2] Allow failures with LISP=ccl-bin for now. --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index 24c39d3..8f343d6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,6 +12,10 @@ env: - LISP=abcl - LISP=ecl +matrix: + allow_failures: + - env: LISP=ccl-bin + addons: apt: packages: