diff options
Diffstat (limited to 'http-client.scm')
| -rw-r--r-- | http-client.scm | 54 |
1 files changed, 39 insertions, 15 deletions
diff --git a/http-client.scm b/http-client.scm index 1eef99d..a0cf59f 100644 --- a/http-client.scm +++ b/http-client.scm @@ -1,7 +1,7 @@ ;;; ;;; Convenient HTTP client library ;;; -;; Copyright (c) 2008-2022, Peter Bex +;; Copyright (c) 2008-2024, Peter Bex ;; Parts copyright (c) 2000-2004, Felix L. Winkelmann ;; All rights reserved. ;; @@ -46,7 +46,7 @@ server-connector default-server-connector prepare-request default-prepare-request) -(import scheme +(import scheme (scheme base) srfi-1 srfi-13 srfi-18 srfi-69 (chicken base) (chicken string) (chicken time) (chicken sort) (chicken io) (chicken file posix) (chicken format) @@ -295,16 +295,16 @@ (or (= pos len) (char-ready? port))) (lambda () ; close (close-input-port port)) - (lambda () ; peek-char + peek-char: (lambda () (if (= pos len) #!eof (peek-char port))) - (lambda (p bytes buf off) ; read-string! + read-bytevector: (lambda (p bytes buf off) (let* ((bytes (min bytes (- len pos))) - (bytes-read (read-string! bytes buf port off))) + (bytes-read (read-bytevector! buf port off (+ off bytes)))) (set! pos (+ pos bytes-read)) bytes-read)) - (lambda (p limit) ; read-line + read-line: (lambda (p limit) (if (= pos len) #!eof (let* ((bytes-left (- len pos)) @@ -716,9 +716,11 @@ '() (let* ((keys (cdr entry)) (file (kv-ref keys file:)) + (data (kv-ref keys data:)) (filename (or (kv-ref keys filename:) - (and (port? file) (port-name file)) - (and (string? file) file))) + (and file + (and (port? file) (port-name file)) + (and (string? file) file)))) (h (headers `((content-disposition #(form-data ((name . ,(car entry)) (filename . ,filename)))) @@ -733,6 +735,7 @@ (list "--" boundary "\r\n" hs "\r\n" (cond ((string? file) (cons 'file file)) ((port? file) (cons 'port file)) + ((string? data) data) ((eq? keys #t) "") (else (->string keys))) ;; The next boundary must always start on a new line @@ -748,14 +751,30 @@ (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))) 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 (bytevector? string)) + size))) + (define (calculate-chunk-size entries) (call/cc (lambda (return) @@ -763,12 +782,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 @@ -797,7 +820,8 @@ ((and (list? writer) (any (lambda (x) (and (pair? x) (pair? (cdr x)) - (eq? (cadr x) file:))) + (or (kv-ref (cdr x) file:) + (kv-ref (cdr x) data:)))) writer)) (let ((bd (conc "----------------Multipart-=_" (gensym 'boundary) "=_=" (current-process-id) |