Check for closed ports when writing chunks and give a hint to the user1.2.2

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)

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"