From 5a510560ca5127888cb4ef5903bca2556d9f679e Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Thu, 26 Jun 2014 23:58:28 +0900
Subject: [PATCH] Including content-length automatically in POST requests.

---
 lib/chibi/net/http.scm | 108 +++++++++++++++++++++++------------------
 1 file changed, 60 insertions(+), 48 deletions(-)

diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm
index 50f75065..f9af2df1 100644
--- a/lib/chibi/net/http.scm
+++ b/lib/chibi/net/http.scm
@@ -103,49 +103,57 @@
 
 ;; A body can be a raw string or bytevector, or an alist of name/value
 ;; pairs.
-(define (http-send-body body boundary out)
+(define (http-send-body headers body out)
   (cond
    ((string? body)
     (display body out))
    ((bytevector? body)
     (write-bytevector body out))
    ((pair? body)
-    (for-each
-     (lambda (x)
-       (display "\r\n--" out)
-       (display boundary out)
-       (let* ((content
-               (if (pair? (cdr x))
-                   (cond ((assq 'value (cdr x)) => cdr)
-                         ((assq 'file (cdr x)) =>
-                          (lambda (x)
-                            (port->bytevector
-                             (open-binary-input-file (cdr x)))))
-                         (else (error "")))
-                   (cdr x)))
-              (content-type
-               (cond ((and (pair? (cdr x))
-                           (or (assq 'content-type (cdr x))
-                               (assq 'Content-Type (cdr x))))
-                      => cdr)
-                     ((string? content) "text/plain")
-                     (else "application/octet-stream"))))
-         (display "\r\nContent-Disposition: form-data; name=\"" out)
-         (display (car x) out)
-         (display "\"" out)
-         (cond ((and (pair? (cdr x)) (assq 'file (cdr x)))
-                => (lambda (x)
-                     (display "; filename=\"" out)
-                     (display (cdr x) out)
-                     (display "\"" out))))
-         (display "\r\nContent-Type: " out)
-         (display content-type out)
-         (display "\r\n\r\n" out)
-         (http-send-body content boundary out)))
-     body)
-    (display "\r\n--" out)
-    (display boundary out)
-    (display "--\r\n" out))))
+    (let* ((ctype (cond ((or (assq 'Content-Type headers)
+                             (assq 'content-type headers))
+                         => (lambda (x)
+                              (mime-parse-content-type (cdr x))))
+                        (else #f)))
+           (boundary (and ctype (assq-ref (cdr ctype) 'boundary))))
+      (for-each
+       (lambda (x)
+         (display "\r\n--" out)
+         (if boundary (display boundary out))
+         (let* ((content
+                 (if (pair? (cdr x))
+                     (cond ((assq 'value (cdr x)) => cdr)
+                           ((assq 'file (cdr x)) =>
+                            (lambda (x)
+                              (port->bytevector
+                               (open-binary-input-file (cdr x)))))
+                           (else (error "")))
+                     (cdr x)))
+                (content-type
+                 (cond ((and (pair? (cdr x))
+                             (or (assq 'content-type (cdr x))
+                                 (assq 'Content-Type (cdr x))))
+                        => cdr)
+                       ((string? content) "text/plain")
+                       (else "application/octet-stream"))))
+           (display "\r\nContent-Disposition: form-data; name=\"" out)
+           (display (car x) out)
+           (display "\"" out)
+           (cond ((and (pair? (cdr x)) (assq 'file (cdr x)))
+                  => (lambda (x)
+                       (display "; filename=\"" out)
+                       (display (cdr x) out)
+                       (display "\"" out))))
+           (display "\r\nContent-Type: " out)
+           (display content-type out)
+           (display "\r\n\r\n" out)
+           (http-send-body headers content out)))
+       body)
+      (display "\r\n--" out)
+      (if boundary (display boundary out))
+      (display "--\r\n" out)))
+   (body
+    (error "unknown body" body))))
 
 (define (http-call-method method url in-headers body limit)
   (if (<= limit 0)
@@ -176,13 +184,7 @@
                  (display (cdr x) out) (display "\r\n" out))
                in-headers)
               (display "Connection: close\r\n\r\n" out)
-              (let* ((ctype (cond ((or (assq 'Content-Type in-headers)
-                                       (assq 'content-type in-headers))
-                                   => (lambda (x)
-                                        (mime-parse-content-type (cdr x))))
-                                  (else #f)))
-                     (boundary (and ctype (assq-ref (cdr ctype) 'boundary))))
-                (http-send-body body boundary out))
+              (http-send-body in-headers body out)
               (flush-output-port out)
               (let* ((resp (http-parse-response (read-line in)))
                      (headers (mime-headers->list in))
@@ -230,10 +232,20 @@
                   (assq headers 'Content-Type))
               headers
               (let ((boundary (http-generate-boundary)))
-                (cons `(Content-Type . ,(string-append
-                                         "multipart/form-data; boundary="
-                                         boundary))
-                      headers)))))
+                `((Content-Type . ,(string-append
+                                    "multipart/form-data; boundary="
+                                    boundary))
+                  ,@headers))))
+         (body
+          (let ((out (open-output-bytevector)))
+            (http-send-body headers body out)
+            (get-output-bytevector out)))
+         (headers
+          (if (or (assq headers 'content-length)
+                  (assq headers 'Content-Length))
+              headers
+              `((Content-Length . ,(bytevector-length body))
+                ,@headers))))
     (cdr (http-call-method 'POST url headers body http-redirect-limit))))
 
 (define (http-put url body . headers)