Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 22:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Including content-length automatically in POST requests.

Browse source
This commit is contained in:
Alex Shinn 2014-06-26 23:58:28 +09:00
parent 908d46f662
commit 5a510560ca
1 changed files with 60 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

108
lib/chibi/net/http.scm
View file

@ -103,49 +103,57 @@
;; A body can be a raw string or bytevector, or an alist of name/value
;; pairs.
(define (http-send-body body boundary out)
(define (http-send-body headers body out)
(cond
((string? body)
(display body out))
((bytevector? body)
(write-bytevector body out))
((pair? body)
(for-each
(lambda (x)
(display "\r\n--" out)
(display boundary out)
(let* ((content
(if (pair? (cdr x))
(cond ((assq 'value (cdr x)) => cdr)
((assq 'file (cdr x)) =>
(lambda (x)
(port->bytevector
(open-binary-input-file (cdr x)))))
(else (error "")))
(cdr x)))
(content-type
(cond ((and (pair? (cdr x))
(or (assq 'content-type (cdr x))
(assq 'Content-Type (cdr x))))
=> cdr)
((string? content) "text/plain")
(else "application/octet-stream"))))
(display "\r\nContent-Disposition: form-data; name=\"" out)
(display (car x) out)
(display "\"" out)
(cond ((and (pair? (cdr x)) (assq 'file (cdr x)))
=> (lambda (x)
(display "; filename=\"" out)
(display (cdr x) out)
(display "\"" out))))
(display "\r\nContent-Type: " out)
(display content-type out)
(display "\r\n\r\n" out)
(http-send-body content boundary out)))
body)
(display "\r\n--" out)
(display boundary out)
(display "--\r\n" out))))
(let* ((ctype (cond ((or (assq 'Content-Type headers)
(assq 'content-type headers))
=> (lambda (x)
(mime-parse-content-type (cdr x))))
(else #f)))
(boundary (and ctype (assq-ref (cdr ctype) 'boundary))))
(for-each
(lambda (x)
(display "\r\n--" out)
(if boundary (display boundary out))
(let* ((content
(if (pair? (cdr x))
(cond ((assq 'value (cdr x)) => cdr)
((assq 'file (cdr x)) =>
(lambda (x)
(port->bytevector
(open-binary-input-file (cdr x)))))
(else (error "")))
(cdr x)))
(content-type
(cond ((and (pair? (cdr x))
(or (assq 'content-type (cdr x))
(assq 'Content-Type (cdr x))))
=> cdr)
((string? content) "text/plain")
(else "application/octet-stream"))))
(display "\r\nContent-Disposition: form-data; name=\"" out)
(display (car x) out)
(display "\"" out)
(cond ((and (pair? (cdr x)) (assq 'file (cdr x)))
=> (lambda (x)
(display "; filename=\"" out)
(display (cdr x) out)
(display "\"" out))))
(display "\r\nContent-Type: " out)
(display content-type out)
(display "\r\n\r\n" out)
(http-send-body headers content out)))
body)
(display "\r\n--" out)
(if boundary (display boundary out))
(display "--\r\n" out)))
(body
(error "unknown body" body))))
(define (http-call-method method url in-headers body limit)
(if (<= limit 0)
@ -176,13 +184,7 @@
(display (cdr x) out) (display "\r\n" out))
in-headers)
(display "Connection: close\r\n\r\n" out)
(let* ((ctype (cond ((or (assq 'Content-Type in-headers)
(assq 'content-type in-headers))
=> (lambda (x)
(mime-parse-content-type (cdr x))))
(else #f)))
(boundary (and ctype (assq-ref (cdr ctype) 'boundary))))
(http-send-body body boundary out))
(http-send-body in-headers body out)
(flush-output-port out)
(let* ((resp (http-parse-response (read-line in)))
(headers (mime-headers->list in))
@ -230,10 +232,20 @@
(assq headers 'Content-Type))
headers
(let ((boundary (http-generate-boundary)))
(cons `(Content-Type . ,(string-append
"multipart/form-data; boundary="
boundary))
headers)))))
`((Content-Type . ,(string-append
"multipart/form-data; boundary="
boundary))
,@headers))))
(body
(let ((out (open-output-bytevector)))
(http-send-body headers body out)
(get-output-bytevector out)))
(headers
(if (or (assq headers 'content-length)
(assq headers 'Content-Length))
headers
`((Content-Length . ,(bytevector-length body))
,@headers))))
(cdr (http-call-method 'POST url headers body http-redirect-limit))))
(define (http-put url body . headers)