summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--http-client.scm22
-rw-r--r--tests/run.scm103
2 files changed, 117 insertions, 8 deletions
diff --git a/http-client.scm b/http-client.scm
index 1eef99d..e9c181b 100644
--- a/http-client.scm
+++ b/http-client.scm
@@ -756,6 +756,14 @@
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 (string? string))
+ size)))
+
(define (calculate-chunk-size entries)
(call/cc
(lambda (return)
@@ -763,12 +771,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
diff --git a/tests/run.scm b/tests/run.scm
index d8118ac..347c18f 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,100 @@
(test "Content type is multipart"
'multipart/form-data
(header-value 'content-type h))
+ (test "Content-length was set"
+ 504 (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"
+ 504 (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 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")))
+
+ (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 +286,9 @@
(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))))
(uri (uri-reference "http://example.com"))
(req (make-request uri: uri method: 'POST
major: 1 minor: 0))
@@ -200,7 +297,7 @@
(with-input-from-request
req
`((lala . "testing")
- (the-file file: ,string-port
+ (the-file file: ,custom-port
filename: "str")
("more" . stuff))
read-string))