Adding post support to the http client library.

This commit is contained in:
Alex Shinn 2014-05-05 22:52:49 +09:00
parent a2cf9db1e5
commit eb3df5c54f
2 changed files with 94 additions and 4 deletions

View file

@ -97,7 +97,57 @@
(make-generated-binary-input-port
(lambda () (read-chunk in))))
(define (http-get/raw url in-headers limit)
(define (http-generate-boundary)
(string-append "chibi-boundary-"
(number->string (random-integer 1000000000))))
;; A body can be a raw string or bytevector, or an alist of name/value
;; pairs.
(define (http-send-body body boundary 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))))
(define (http-call-method method url in-headers body limit)
(if (<= limit 0)
(error "http-get: redirect limit reached" url)
(let* ((uri (if (uri? url) url (string->uri url)))
@ -110,7 +160,8 @@
(if (eq? 'https (uri-scheme uri)) 443 80))))
(in (cadr io))
(out (car (cddr io))))
(display "GET " out)
(display method out)
(display " " out)
(display (or (uri-path uri) "/") out)
(display " HTTP/1.0\r\n" out)
(display "Host: " out) (display host out) (display "\r\n" out)
@ -125,6 +176,13 @@
(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))
(flush-output-port out)
(let* ((resp (http-parse-response (read-line in)))
(headers (mime-headers->list in))
@ -149,6 +207,9 @@
(close-output-port out)
(error "couldn't retrieve url" url resp)))))))))
(define (http-get/raw url headers limit)
(http-call-method 'GET url headers #f limit))
(define (http-get/headers url . headers)
(http-get/raw url
(if (pair? headers) (car headers) '())
@ -157,6 +218,34 @@
(define (http-get url . headers)
(cdr (apply http-get/headers url headers)))
(define (http-head url . headers)
(car (http-call-method 'HEAD url
(if (pair? headers) (car headers) '()) #f
http-redirect-limit)))
(define (http-post url body . o)
(let* ((headers (if (pair? o) (car o) '()))
(headers
(if (or (assq headers 'content-type)
(assq headers 'Content-Type))
headers
(let ((boundary (http-generate-boundary)))
(cons `(Content-Type . ,(string-append
"multipart/form-data; boundary="
boundary))
headers)))))
(cdr (http-call-method 'POST url headers body http-redirect-limit))))
(define (http-put url body . headers)
(cdr (http-call-method 'PUT url
(if (pair? headers) (car headers) '()) body
http-redirect-limit)))
(define (http-delete url . headers)
(cdr (http-call-method 'DELETE url
(if (pair? headers) (car headers) '()) #f
http-redirect-limit)))
(define (call-with-input-url url proc)
(let* ((p (http-get url))
(res (proc p)))

View file

@ -1,10 +1,11 @@
(define-library (chibi net http)
(export http-get http-get/headers
http-head http-post http-put http-delete
call-with-input-url call-with-input-url/headers
with-input-from-url
http-parse-request http-parse-form)
(import (scheme base) (scheme write) (scheme char)
(srfi 39)
(import (scheme base) (scheme write) (scheme char) (scheme file)
(srfi 27) (srfi 39)
(chibi net) (chibi io) (chibi uri) (chibi mime))
(include "http.scm"))