Try to determine multipart content length for string ports

This makes it slightly more reliable for certain servers which
absolutely require content length.

An alternative would be to have an explicit API for sending static
string contents.  This could be in addition to this approach, because
this should always be a net win.

2 files changed, 117 insertions, 8 deletions

diff --git a/http-client.scm b/http-client.scm
index 1eef99d..e9c181b 100644
--- a/http-client.scm
+++ b/http-client.scm
@@ -756,6 +756,14 @@
                         entry))
             entries))
 
+(define (maybe-string-port-length port)
+  (and (eq? (##sys#slot port 7) 'string) ; type
+       (let ((size (##sys#slot port 11))
+             (string (##sys#slot port 12)))
+         (assert (integer? size))       ; Check our assumptions; this is pretty unsafe code
+         (assert (string? string))
+         size)))
+
 (define (calculate-chunk-size entries)
   (call/cc
    (lambda (return)
@@ -763,12 +771,16 @@
              (fold (lambda (chunk total-size)
                      (if (pair? chunk)
                          (if (eq? 'port (car chunk))
+                             (let ((str-len (maybe-string-port-length (cdr chunk))))
+                               (if str-len
+                                   (+ total-size str-len)
+                                   ;; We can't calculate port lengths
+                                   ;; for non-string-ports.  Let's just
+                                   ;; punt and hope the server won't
+                                   ;; return "411 Length Required"...
+                                   ;; (TODO: maybe try seeking it?)
+                                   (return #f)))
                              ;; Should be a file otherwise.
-                             ;; We can't calculate port lengths.
-                             ;; Let's just punt and hope the server
-                             ;; won't return "411 Length Required"...
-                             ;; (TODO: maybe try seeking it?)
-                             (return #f)
                              (+ total-size (file-size (cdr chunk))))
                          (+ total-size (string-length chunk))))
                    total-size
diff --git a/tests/run.scm b/tests/run.scm
index d8118ac..347c18f 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -3,6 +3,8 @@
 (include "../http-client.scm")
 (import http-client)
 
+(import (chicken port))
+
 (include "testlib.scm")
 
 (test-begin "http-client")
@@ -145,7 +147,7 @@
       (test "Body was sent correctly"
             "lala=testing&another=data&more=stuff" (log-body log))))
 
-  (test-group "alist form data body with file port"
+  (test-group "alist form data body with string port"
     (let* ((string-port (open-input-string "the file's contents"))
            (log (with-server-response
                  (lambda ()
@@ -179,6 +181,100 @@
       (test "Content type is multipart"
             'multipart/form-data
             (header-value 'content-type h))
+      (test "Content-length was set"
+            504 (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"))
+           (req (make-request uri: uri method: 'POST
+                              major: 1 minor: 0))
+           (log (with-server-response
+                 (lambda ()
+                   (with-input-from-request
+                    req
+                    `((lala . "testing")
+                      (the-file file: ,string-port
+                                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-file\"; "
+             "filename=\"str\"\r\n"
+             "Content-Type: application/octet-stream\r\n\r\n"
+             "the file'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"
+            504 (header-value 'content-length h))
+      (test "Version is correct"
+            '(1 . 0)
+            (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 custom port"
+    (let* ((string-port (open-input-string "the file's contents"))
+           (custom-port (make-input-port (lambda () (read-char string-port)) (constantly #t) (lambda () (close-input-port string-port))))
+           (log (with-server-response
+                 (lambda ()
+                   (with-input-from-request
+                    "http://example.com"
+                    `((lala . "testing")
+                      (the-file file: ,custom-port
+                                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-file\"; "
+             "filename=\"str\"\r\n"
+             "Content-Type: application/octet-stream\r\n\r\n"
+             "the file'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 not set"
             #f (header-value 'content-length h))
       (test "Version is the default HTTP version of 1.1"
@@ -190,8 +286,9 @@
       (test "Body contains the file and other data, delimited by the boundary"
             expected-data (log-body log))))
 
-  (test-group "alist form data body with file port using HTTP/1.0"
+  (test-group "alist form data body with custom port using HTTP/1.0"
     (let* ((string-port (open-input-string "the file's contents"))
+           (custom-port (make-input-port (lambda () (read-char string-port)) (constantly #t) (lambda () (close-input-port string-port))))
            (uri (uri-reference "http://example.com"))
            (req (make-request uri: uri method: 'POST
                               major: 1 minor: 0))
@@ -200,7 +297,7 @@
                    (with-input-from-request
                     req
                     `((lala . "testing")
-                      (the-file file: ,string-port
+                      (the-file file: ,custom-port
                                 filename: "str")
                       ("more" . stuff))
                     read-string))