http-post

[gregory benison <gbenison@gmail.com>]

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 <gbenison@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))))))