summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--http-client.release-info8
-rw-r--r--http-client.scm51
-rw-r--r--tests/run.scm132
-rw-r--r--tests/testlib.scm2
4 files changed, 103 insertions, 90 deletions
diff --git a/http-client.release-info b/http-client.release-info
index 5362832..e152e56 100644
--- a/http-client.release-info
+++ b/http-client.release-info
@@ -1,8 +1,4 @@
(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 "1.2.2")
+(release "2.0")
+(release "2.0.1")
diff --git a/http-client.scm b/http-client.scm
index 58d045d..2d5e182 100644
--- a/http-client.scm
+++ b/http-client.scm
@@ -1,7 +1,7 @@
;;;
;;; Convenient HTTP client library
;;;
-;; Copyright (c) 2008-2024, 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
@@ -772,7 +779,7 @@
(let ((size (##sys#slot port 11))
(string (##sys#slot port 12)))
(assert (integer? size)) ; Check our assumptions; this is pretty unsafe code
- (assert (string? string))
+ (assert (bytevector? string))
size)))
(define (calculate-chunk-size entries)
diff --git a/tests/run.scm b/tests/run.scm
index 7759b24..0308bcc 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -303,35 +303,40 @@
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))))
- (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")))
+ (letrec* ((string-port (open-input-string "the file's contents"))
+ (read-bv-from-sp (case-lambda ((p bytes buf off) (read-bv-from-sp buf off (+ bytes off)))
+ ((buf start end) (read-bytevector! buf string-port start end))))
+ (custom-port (make-input-port (lambda () (read-char string-port))
+ (constantly #t)
+ (lambda () (close-input-port string-port))
+ read-bytevector: read-bv-from-sp))
+ (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"
@@ -349,38 +354,43 @@
expected-data (log-body log))))
(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))))
- (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: ,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")))
+ (letrec* ((string-port (open-input-string "the file's contents"))
+ (read-bv-from-sp (case-lambda ((p bytes buf off) (read-bv-from-sp buf off (+ bytes off)))
+ ((buf start end) (read-bytevector! buf string-port start end))))
+ (custom-port (make-input-port (lambda () (read-char string-port))
+ (constantly #t)
+ (lambda () (close-input-port string-port))
+ read-bytevector: read-bv-from-sp))
+ (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: ,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"
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.46.0) at 2026-09-17 17:54:24 +0000