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