diff options
Diffstat (limited to 'http-client.scm')
| -rw-r--r-- | http-client.scm | 91 |
1 files changed, 61 insertions, 30 deletions
diff --git a/http-client.scm b/http-client.scm index 1eef99d..2d5e182 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-2026, 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) (scheme case-lambda) srfi-1 srfi-13 srfi-18 srfi-69 (chicken base) (chicken string) (chicken time) (chicken sort) (chicken io) (chicken file posix) (chicken format) @@ -62,7 +62,6 @@ ;; needed if there are webservers out there that send the same nonce ;; repeatedly. This client doesn't do request pipelining so we don't ;; generate requests with the same nonce if the server doesn't) -;; * Test and document SSL support ;; * The authenticators stuff is really really ugly. It's intentionally ;; undocumented so nobody is going to rely on it too much yet, and ;; we have the freedom to change it later. @@ -284,6 +283,18 @@ (if (not len) port ;; no need to delimit anything (let ((pos 0)) + ;; NOTE: This is using case-lambda because the signature changed between CHICKEN 6.0.0 and later releases + ;; In 6.0.0 it receives the port and the the number of bytes to read so we have to convert that old + ;; signature to the newer signature. + (define read-bytevector/pos + (case-lambda + ((p bytes buf off) + (read-bytevector/pos buf off (+ bytes off))) + ((buf start end) + (let* ((bytes (min (- end start) (- len pos))) + (bytes-read (read-bytevector! buf port start (+ start bytes)))) + (set! pos (+ pos bytes-read)) + bytes-read)))) (make-input-port (lambda () ; read-char (if (= pos len) @@ -295,24 +306,20 @@ (or (= pos len) (char-ready? port))) (lambda () ; close (close-input-port port)) - (lambda () ; peek-char - (if (= pos len) - #!eof - (peek-char port))) - (lambda (p bytes buf off) ; read-string! - (let* ((bytes (min bytes (- len pos))) - (bytes-read (read-string! bytes buf port off))) - (set! pos (+ pos bytes-read)) - bytes-read)) - (lambda (p limit) ; read-line - (if (= pos len) - #!eof - (let* ((bytes-left (- len pos)) - (limit (min (or limit bytes-left) bytes-left)) - (line (read-line port limit))) - (unless (eof-object? line) - (set! pos (+ pos (string-length line)))) - line))))))) + peek-char: (lambda () + (if (= pos len) + #!eof + (peek-char port))) + read-bytevector: read-bytevector/pos + read-line: (lambda (p limit) + (if (= pos len) + #!eof + (let* ((bytes-left (- len pos)) + (limit (min (or limit bytes-left) bytes-left)) + (line (read-line port limit))) + (unless (eof-object? line) + (set! pos (+ pos (string-length line)))) + line))))))) (define discard-remaining-data! (let ((buf (make-string 1024))) ; Doesn't matter, discarded anyway @@ -716,9 +723,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 +742,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 +758,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 +789,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 +827,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) |