Re: http-post

[Noah Lavine]

Hello,

Thanks for sending it in! And sorry for the slow response.

If you'd like to have it added to Guile, we'd love to have it in here.
The one other thing we'd like is tests for this code. There are
examples in test-suite/tests/web-http.test.

If you want, you can also write a git log entry to go with this. The
other entries have examples. That isn't as important as tests, though.

Thanks for contributing,
Noah

On Mon, Apr 16, 2012 at 11:34 PM, gregory benison <address@hidden> wrote:
> 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 <address@hidden>."
>
> 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 <address@hidden>
> [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))))))
>