mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 21:47:33 +02:00
Adding post support to the http client library.
This commit is contained in:
parent
a2cf9db1e5
commit
eb3df5c54f
2 changed files with 94 additions and 4 deletions
|
@ -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)))
|
||||
|
|
|
@ -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"))
|
||||
|
|
Loading…
Add table
Reference in a new issue