From 8f92a6c32da01150400261515d3a4aa8a6ac4470 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 28 Jun 2024 09:04:48 +0200 Subject: Check for closed ports when writing chunks and give a hint to the user This makes it a bit more obvious what happened in cases like #1838, reported by Woodrow E Douglass. While at it, add some more test cases for this particular case, but also for retry-attempts, as this is also affected when retry is allowed for non-idempotent requests (which is pretty uncommon, but possible) --- http-client.scm | 10 +++- tests/run.scm | 140 +++++++++++++++++++++++++++++++++++--------------------- 2 files changed, 97 insertions(+), 53 deletions(-) diff --git a/http-client.scm b/http-client.scm index 0dd9dff..58d045d 100644 --- a/http-client.scm +++ b/http-client.scm @@ -751,8 +751,16 @@ (open-input-file (cdr chunk)) ;; Should be a port otherwise (cdr chunk)))) + (when (port-closed? p) + (raise (http-client-error 'call-with-input-request* + (conc "At least one port for the multipart body has been already " + "consumed and closed. This may be due to a retry or a redirect. " + "Hint: use 'data:' or limit max-retry-attempts and " + "max-redirect-depth to zero and catch the resulting exception") + (list p) + 'port-already-consumed 'port p))) (handle-exceptions exn - (begin (close-input-port p) (raise exn)) + (begin (close-input-port p) (raise exn)) (sendfile p output-port)) (close-input-port p)) (display chunk output-port))) diff --git a/tests/run.scm b/tests/run.scm index 7d0653b..7759b24 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -192,50 +192,6 @@ (test "Body contains the file and other data, delimited by the boundary" expected-data (log-body log)))) - (test-group "alist form data body with string data" - (let* ((log (with-server-response - (lambda () - (with-input-from-request - "http://example.com" - `((lala . "testing") - (the-data data: "the data's contents" - filename: "str") - ("more" . stuff)) - read-string)) - "HTTP/1.0 200 OK\r\n\r\n")) - (req (log-request log)) - (h (request-headers req)) - (boundary (header-param 'boundary 'content-type h)) - (expected-data - (conc - "--" boundary "\r\n" - "Content-Disposition: form-data; name=\"lala\"\r\n\r\n" - "testing\r\n" - "--" boundary "\r\n" - "Content-Disposition: form-data; name=\"the-data\"; " - "filename=\"str\"\r\n" - "Content-Type: application/octet-stream\r\n\r\n" - "the data's contents\r\n" - "--" boundary "\r\n" - "Content-Disposition: form-data; name=\"more\"\r\n\r\n" - "stuff\r\n" - "--" boundary "--\r\n"))) - - (test "Request method" 'POST (request-method req)) - (test "Content type is multipart" - 'multipart/form-data - (header-value 'content-type h)) - (test "Content-length was set" - (string-length expected-data) (header-value 'content-length h)) - (test "Version is the default HTTP version of 1.1" - '(1 . 1) - (cons (request-major req) (request-minor req))) - (test "Transfer encoding is not set" - #f - (header-value 'transfer-encoding (request-headers req))) - (test "Body contains the file and other data, delimited by the boundary" - expected-data (log-body log)))) - (test-group "alist form data body with string port using HTTP/1.0" (let* ((string-port (open-input-string "the file's contents")) (uri (uri-reference "http://example.com")) @@ -284,14 +240,29 @@ (test "Body contains the file and other data, delimited by the boundary" expected-data (log-body log)))) - (test-group "alist form data body with string data using HTTP/1.0" - (let* ((uri (uri-reference "http://example.com")) - (req (make-request uri: uri method: 'POST - major: 1 minor: 0)) - (log (with-server-response + (test-group "alist form data body with string port with redirect" + (test-error* "results in a port already consumed error" + (exn http port-already-consumed) + (let ((string-port (open-input-string "the file's contents"))) + (with-server-responses + (lambda () + (with-input-from-request + "http://example.com" + `((lala . "testing") + (the-file file: ,string-port + filename: "str") + ("more" . stuff)) + read-string)) + (conc "HTTP/1.0 301 Moved Permanently\r\n" + "Location: http://example.org/different/path\r\n" + "Content-Length: 8\r\n\r\nIgnored!") + "HTTP/1.0 200 OK\r\n\r\n")))) + + (test-group "alist form data body with string data" + (let* ((log (with-server-response (lambda () (with-input-from-request - req + "http://example.com" `((lala . "testing") (the-data data: "the data's contents" filename: "str") @@ -322,8 +293,8 @@ (header-value 'content-type h)) (test "Content-length was set" (string-length expected-data) (header-value 'content-length h)) - (test "Version is correct" - '(1 . 0) + (test "Version is the default HTTP version of 1.1" + '(1 . 1) (cons (request-major req) (request-minor req))) (test "Transfer encoding is not set" #f @@ -420,6 +391,8 @@ (test "Version is correct" '(1 . 0) (cons (request-major req) (request-minor req))) + ;; This is the important part - no chunking! And also, connection is closed, + ;; but we can't test for that here unless we expose the idle-connections pool. (test "Transfer encoding is not set" #f (header-value 'transfer-encoding (request-headers req))) @@ -708,6 +681,69 @@ '(1 1) (list (request-major req) (request-minor req))) (test "No body got sent (GET)" #f (log-body (last logs)))))) + (test-group "with POST and default value for 'retry-request?'" + (test-error* "results in a premature disconnection error due to retries not allowed for non-idempotent requests" + (exn http premature-disconnection) + (parameterize ((max-retry-attempts 3)) + (with-server-responses + (lambda () + (with-input-from-request + "http://example.com/blah" + `((lala . "testing") + (another . "thing")) + read-string)) + "" + (conc "HTTP/1.0 200 OK\r\n" + "Content-Length: 63\r\n\r\n" + "It would've worked on the second attempt, but we never get here"))))) + + (test-group "with POST and allowing retries for non-idempotent connections" + (parameterize ((retry-request? (constantly #t)) + (max-retry-attempts 3)) + (let* ((logs (with-server-responses + (lambda () + (with-input-from-request + "http://example.com/blah" + `((lala . "testing") + ("more" . stuff)) + read-string)) + "" + (conc "HTTP/1.0 200 OK\r\n" + "Content-Length: 63\r\n\r\n" + "It would've worked on the second attempt, but we never get here"))) + (req (log-request (last logs)))) + + ;; Just a few random checks + (test "URI is still OK" + "/blah" (uri->string (request-uri req))) + (test "host header is also OK" + '("example.com" . #f) + (header-value 'host (request-headers req))) + (test "HTTP request is version 1.1" + '(1 1) (list (request-major req) (request-minor req))) + (test "Body got sent again" + "lala=testing&more=stuff" (log-body (last logs)))))) + + (test-group "with port in data and allowing retries for non-idempotent connections" + (let ((string-port (open-input-string "the file's contents"))) + (test-error* "results in a port already consumed error" + (exn http port-already-consumed) + (parameterize ((retry-request? (constantly #t)) + (max-retry-attempts 3)) + (with-server-responses + (lambda () + (with-input-from-request + "http://example.com/blah" + `((lala . "testing") + (the-file file: ,string-port + filename: "str") + (another . "thing")) + read-string)) + "" + (conc "HTTP/1.0 200 OK\r\n" + "Content-Length: 63\r\n\r\n" + "It would've worked on the second attempt, but we never get here")))))) + (test-group "exceeding maximum retries" (parameterize ((max-retry-attempts 3)) (test-error* "results in a premature disconnection error" -- cgit v1.2.3