#1838: http-client does not multipart encode string ports properly

[Chicken Trac]

#1838: http-client does not multipart encode string ports properly
----------------------------------+------------------------------
            Reporter:  wdouglass  |       Type:  defect
              Status:  new        |   Priority:  major
           Milestone:  someday    |  Component:  unknown
             Version:  5.3.0      |   Keywords:  http http-client
Estimated difficulty:             |
----------------------------------+------------------------------
 When passing a string-port as part of the `writer` argument to `with-
 input-from-request`, the encoding step tries to read the port (i guess to
 get length?), closes it, and then tries to read it again and crashes.

 I am relatively new at chicken scheme, and could not see a clean way to
 solve this issue. I worked around it with the below patch, by allowing a
 thunk to be passed that gets called for a new string port each time it's
 needed. this seems to work (although i am still testing)

 If there is another place i should submit this patch, or if I've done
 anything obviously wrong (technically or project ettiquite), Please let me
 know. Thank you.

 {{{
 From 13eb8902e0505e26e6f41dd9b36e9f85460ba58a Mon Sep 17 00:00:00 2001
 From: Woodrow Douglass <wdouglass@carnegierobotics.com>
 Date: Mon, 24 Jun 2024 13:04:30 -0400
 Subject: [PATCH] accept a procedure for file content, which is a thunk
 that
  returns a port

 ---
  http-client.scm | 40 +++++++++++++++++++++++-----------------
  1 file changed, 23 insertions(+), 17 deletions(-)

 diff --git a/http-client.scm b/http-client.scm
 index e9c181b..922ddfd 100644
 --- a/http-client.scm
 +++ b/http-client.scm
 @@ -733,6 +733,7 @@
                  (list "--" boundary "\r\n" hs "\r\n"
                        (cond ((string? file) (cons 'file file))
                              ((port? file) (cons 'port file))
 +                            ((procedure? file) (cons 'procedure file))
                              ((eq? keys #t) "")
                              (else (->string keys)))
                    ;; The next boundary must always start on a new line
 @@ -744,12 +745,17 @@
    (for-each (lambda (entry)
                (for-each (lambda (chunk)
                            (if (pair? chunk)
 -                              (let ((p (if (eq? 'file (car chunk))
 -                                           (open-input-file (cdr chunk))
 -                                           ;; Should be a port otherwise
 -                                           (cdr chunk))))
 +                              (let ((p (case (car chunk)
 +                                         ((file) (open-input-file (cdr
 chunk)))
 +                                         ((port) (cdr chunk))
 +                                         ((procedure) ((cdr chunk)))
 +                                         (else (http-client-error
 +                                                'write-chunks
 +                                                "The a file chunk must be
 either a string representing a filename, an open port, or a thunk that
 returns an open port"
 +                                                '()
 +                                                'multipart-file-
 error)))))
                                  (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)))
 @@ -770,18 +776,18 @@
       (fold (lambda (chunks total-size)
               (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.
 -                             (+ total-size (file-size (cdr chunk))))
 +                         (if (eq? 'file (car chunk))
 +                             (+ total-size (file-size (cdr chunk)))
 +                             (let ((p (if (eq? 'port (car chunk)) (cdr
 chunk) ((cdr 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)))))
                           (+ total-size (string-length chunk))))
                     total-size
                     chunks))
 --
 2.39.2
 }}}

-- 
Ticket URL: <https://bugs.call-cc.org/ticket/1838>
CHICKEN Scheme <https://www.call-cc.org/>
CHICKEN Scheme is a compiler for the Scheme programming language.