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 (make-generated-binary-input-port
(lambda () (read-chunk in)))) (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) (if (<= limit 0)
(error "http-get: redirect limit reached" url) (error "http-get: redirect limit reached" url)
(let* ((uri (if (uri? url) url (string->uri url))) (let* ((uri (if (uri? url) url (string->uri url)))
@ -110,7 +160,8 @@
(if (eq? 'https (uri-scheme uri)) 443 80)))) (if (eq? 'https (uri-scheme uri)) 443 80))))
(in (cadr io)) (in (cadr io))
(out (car (cddr io)))) (out (car (cddr io))))
(display "GET " out) (display method out)
(display " " out)
(display (or (uri-path uri) "/") out) (display (or (uri-path uri) "/") out)
(display " HTTP/1.0\r\n" out) (display " HTTP/1.0\r\n" out)
(display "Host: " out) (display host out) (display "\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)) (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)
(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))
@ -149,6 +207,9 @@
(close-output-port out) (close-output-port out)
(error "couldn't retrieve url" url resp))))))))) (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) (define (http-get/headers url . headers)
(http-get/raw url (http-get/raw url
(if (pair? headers) (car headers) '()) (if (pair? headers) (car headers) '())
@ -157,6 +218,34 @@
(define (http-get url . headers) (define (http-get url . headers)
(cdr (apply http-get/headers 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) (define (call-with-input-url url proc)
(let* ((p (http-get url)) (let* ((p (http-get url))
(res (proc p))) (res (proc p)))

View file

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