summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--http-client.release-info6
-rw-r--r--http-client.scm54
-rw-r--r--tests/run.scm236
-rw-r--r--tests/testlib.scm2
4 files changed, 274 insertions, 24 deletions
diff --git a/http-client.release-info b/http-client.release-info
index 69ce7c5..82afc87 100644
--- a/http-client.release-info
+++ b/http-client.release-info
@@ -1,7 +1,3 @@
(repo git "https://code.more-magic.net/{egg-name}")
(uri targz "https://code.more-magic.net/{egg-name}/snapshot/{egg-name}-{egg-release}.tar.gz")
-(release "1.0")
-(release "1.1")
-(release "1.1.1")
-(release "1.2")
-(release "1.2.1")
+(release "2.0")
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)
diff --git a/tests/run.scm b/tests/run.scm
index d8118ac..9ad7fd8 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,165 @@
(test "Content type is multipart"
'multipart/form-data
(header-value 'content-type h))
+ (test "Content-length was set"
+ (string-length expected-data) (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"
+ (string-length expected-data) (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 string port with redirect"
+ (test-error* "results in a port already consumed error"
+ (exn http port-already-consumed)
+ (let ((string-port (open-input-string "the file's contents")))
+ (with-server-responses
+ (lambda ()
+ (with-input-from-request
+ "http://example.com"
+ `((lala . "testing")
+ (the-file file: ,string-port
+ filename: "str")
+ ("more" . stuff))
+ read-string))
+ (conc "HTTP/1.0 301 Moved Permanently\r\n"
+ "Location: http://example.org/different/path\r\n"
+ "Content-Length: 8\r\n\r\nIgnored!")
+ "HTTP/1.0 200 OK\r\n\r\n"))))
+
+ (test-group "alist form data body with string data"
+ (let* ((log (with-server-response
+ (lambda ()
+ (with-input-from-request
+ "http://example.com"
+ `((lala . "testing")
+ (the-data data: "the data's contents"
+ 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-data\"; "
+ "filename=\"str\"\r\n"
+ "Content-Type: application/octet-stream\r\n\r\n"
+ "the data'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"
+ (string-length expected-data) (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 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))
+ read-bytevector: (lambda (p bytes buf off) (read-bytevector! buf string-port off bytes))))
+ (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 +351,12 @@
(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))
+ read-bytevector: (lambda (p bytes buf off) (read-bytevector! buf string-port off bytes))))
(uri (uri-reference "http://example.com"))
(req (make-request uri: uri method: 'POST
major: 1 minor: 0))
@@ -200,7 +365,7 @@
(with-input-from-request
req
`((lala . "testing")
- (the-file file: ,string-port
+ (the-file file: ,custom-port
filename: "str")
("more" . stuff))
read-string))
@@ -232,6 +397,8 @@
(test "Version is correct"
'(1 . 0)
(cons (request-major req) (request-minor req)))
+ ;; This is the important part - no chunking! And also, connection is closed,
+ ;; but we can't test for that here unless we expose the idle-connections pool.
(test "Transfer encoding is not set"
#f
(header-value 'transfer-encoding (request-headers req)))
@@ -520,6 +687,69 @@
'(1 1) (list (request-major req) (request-minor req)))
(test "No body got sent (GET)" #f (log-body (last logs))))))
+ (test-group "with POST and default value for 'retry-request?'"
+ (test-error* "results in a premature disconnection error due to retries not allowed for non-idempotent requests"
+ (exn http premature-disconnection)
+ (parameterize ((max-retry-attempts 3))
+ (with-server-responses
+ (lambda ()
+ (with-input-from-request
+ "http://example.com/blah"
+ `((lala . "testing")
+ (another . "thing"))
+ read-string))
+ ""
+ (conc "HTTP/1.0 200 OK\r\n"
+ "Content-Length: 63\r\n\r\n"
+ "It would've worked on the second attempt, but we never get here")))))
+
+ (test-group "with POST and allowing retries for non-idempotent connections"
+ (parameterize ((retry-request? (constantly #t))
+ (max-retry-attempts 3))
+ (let* ((logs (with-server-responses
+ (lambda ()
+ (with-input-from-request
+ "http://example.com/blah"
+ `((lala . "testing")
+ ("more" . stuff))
+ read-string))
+ ""
+ (conc "HTTP/1.0 200 OK\r\n"
+ "Content-Length: 63\r\n\r\n"
+ "It would've worked on the second attempt, but we never get here")))
+ (req (log-request (last logs))))
+
+ ;; Just a few random checks
+ (test "URI is still OK"
+ "/blah" (uri->string (request-uri req)))
+ (test "host header is also OK"
+ '("example.com" . #f)
+ (header-value 'host (request-headers req)))
+ (test "HTTP request is version 1.1"
+ '(1 1) (list (request-major req) (request-minor req)))
+ (test "Body got sent again"
+ "lala=testing&more=stuff" (log-body (last logs))))))
+
+ (test-group "with port in data and allowing retries for non-idempotent connections"
+ (let ((string-port (open-input-string "the file's contents")))
+ (test-error* "results in a port already consumed error"
+ (exn http port-already-consumed)
+ (parameterize ((retry-request? (constantly #t))
+ (max-retry-attempts 3))
+ (with-server-responses
+ (lambda ()
+ (with-input-from-request
+ "http://example.com/blah"
+ `((lala . "testing")
+ (the-file file: ,string-port
+ filename: "str")
+ (another . "thing"))
+ read-string))
+ ""
+ (conc "HTTP/1.0 200 OK\r\n"
+ "Content-Length: 63\r\n\r\n"
+ "It would've worked on the second attempt, but we never get here"))))))
+
(test-group "exceeding maximum retries"
(parameterize ((max-retry-attempts 3))
(test-error* "results in a premature disconnection error"
diff --git a/tests/testlib.scm b/tests/testlib.scm
index 92e69da..e50e5da 100644
--- a/tests/testlib.scm
+++ b/tests/testlib.scm
@@ -3,7 +3,7 @@
;; TODO: Test HTTPS somehow?
-(import test uri-common intarweb srfi-1 srfi-18 (chicken tcp)
+(import (scheme base) test uri-common intarweb srfi-1 srfi-18 (chicken tcp)
(chicken string) (chicken io) (chicken file) (chicken format))
;; From intarweb
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-03 08:21:29 +0000