>From the guile reference manual, web section: "More helper procedures for the other common HTTP verbs would be a good addition to this module. Send your code to <guile-user@gnu.org>."
So, I say to guile-user, "here is my code". This http-post implementation takes the request body as either a bytevector or as a string, in which case it first converts it to a bytevector either using a default encoding (currently always utf-8, but perhaps should be snarfed from the current locale) or using a caller-requested encoding (currently only utf-8 is accepted, though). I think the next steps after this patch are to: - be able to work with a greater variety of encodings; - since form data of the type "key1=value1&key2=value2..." is so common in POST bodies, accept post data as key-value pairs represented by an alist (which would be coerced into a bytevector automatically). -- Greg Benison <gbeni...@gmail.com> [blog] http://gcbenison.wordpress.com [twitter] @gcbenison diff --git a/module/web/client.scm b/module/web/client.scm index b035668..6ecc07c 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -35,11 +35,12 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:export (open-socket-for-uri - http-get)) + http-get http-post)) (define (open-socket-for-uri uri) (let* ((ai (car (getaddrinfo (uri-host uri) @@ -114,3 +115,67 @@ (if decode-body? (decode-response-body res body) body))))) + +;; Add a default 'content-type' header to 'headers', +;; if none is present. +(define (with-default-encoding headers) + (if (assoc 'content-type headers) + headers + (cons + '(content-type text/plain (charset . "utf-8")) + headers))) + +;; Query headers for a valid 'content-type entry; encode 'content' +;; appropriately into a bytevector. Throws 'invalid-encoding +;; if no appropriate encoding found. +(define (encode-for-headers content headers) + (let ((content-type (assoc 'content-type headers))) + (if (not content-type) + (throw 'invalid-encoding)) + (let ((encoding (assoc 'charset (cddr content-type)))) + (cond ((not encoding) + (throw 'invalid-encoding)) + ((equal? "utf-8" (cdr encoding)) + (string->utf8 content)) + (else (throw 'invalid-encoding (cdr encoding))))))) + +;; Encode 'content' as a bytevector, and append needed headers +;; to 'headers', in particular 'content-length' +(define (encode-content content headers) + (receive (content-bv headers) + (cond ((bytevector? content) + (values content headers)) + ((string? content) + (let ((headers (with-default-encoding headers))) + (values (encode-for-headers content headers) + headers))) + (else (error "invalid content type"))) + ;; FIXME what if 'headers' already contains a content-length? + (values content-bv + (cons `(content-length . ,(bytevector-length content-bv)) + headers)))) + +(define* (http-post uri content #:key (port (open-socket-for-uri uri)) + (version '(1 . 1)) + (keep-alive? #f) + (extra-headers '()) + (decode-body? #t)) + (receive (content headers) + (encode-content content extra-headers) + (let ((req (build-request uri + #:method "POST" + #:version version + #:headers (if keep-alive? + headers + (cons '(connection close) + headers))))) + (write-request-body + (write-request req port) + content) + (force-output port) + (let* ((response (read-response port)) + (body (read-response-body response))) + (values response + (if decode-body? + (decode-response-body response body) + body))))))
