[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-13-g037a680

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=037a68032165a2f1e4c0311baa9f69e2a05c3326

The branch, stable-2.0 has been updated
       via  037a68032165a2f1e4c0311baa9f69e2a05c3326 (commit)
       via  680c8c5a99e6abe040752c3471cd42a9516842b6 (commit)
      from  126a32243146d9ad238a3a5adb8d6af5a87ad2aa (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 037a68032165a2f1e4c0311baa9f69e2a05c3326
Author: Andy Wingo <address@hidden>
Date:   Fri Jul 15 13:08:45 2011 +0200

    ensure presence of Host header in HTTP/1.1 requests
    
    * module/web/request.scm (build-request): Make sure that HTTP/1.1
      requests have the Host header set, per RFC 2616 section 9.
    
    * test-suite/tests/web-request.test ("example-1"): Add test.

commit 680c8c5a99e6abe040752c3471cd42a9516842b6
Author: Andy Wingo <address@hidden>
Date:   Fri Jul 15 12:49:46 2011 +0200

    add (web client)
    
    * module/web/client.scm: New module, a simple synchronous web client.
    
    * module/Makefile.am (WEB_SOURCES): Add to the build.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                |    1 +
 module/web/client.scm             |  115 +++++++++++++++++++++++++++++++++++++
 module/web/request.scm            |   40 ++++++++-----
 test-suite/tests/web-request.test |    4 +
 4 files changed, 145 insertions(+), 15 deletions(-)
 create mode 100644 module/web/client.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index b21b73c..2357e19 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -356,6 +356,7 @@ LIB_SOURCES =                                       \
   texinfo/serialize.scm
 
 WEB_SOURCES =                                  \
+  web/client.scm                               \
   web/http.scm                                 \
   web/request.scm                              \
   web/response.scm                             \
diff --git a/module/web/client.scm b/module/web/client.scm
new file mode 100644
index 0000000..321c7db
--- /dev/null
+++ b/module/web/client.scm
@@ -0,0 +1,115 @@
+;;; Web client
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; (web client) is a simple HTTP URL fetcher for Guile.
+;;;
+;;; In its current incarnation, (web client) is synchronous.  If you
+;;; want to fetch a number of URLs at once, probably the best thing to
+;;; do is to write an event-driven URL fetcher, similar in structure to
+;;; the web server.
+;;;
+;;; Another option, good but not as performant, would be to use threads,
+;;; possibly via par-map or futures.
+;;;
+;;; Code:
+
+(define-module (web client)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (open-socket-for-uri
+            http-get))
+
+(define (open-socket-for-uri uri)
+  (let* ((ai (car (getaddrinfo (uri-host uri)
+                               (cond
+                                ((uri-port uri) => number->string)
+                                (else (symbol->string (uri-scheme uri)))))))
+         (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                     (addrinfo:protocol ai))))
+    (connect s (addrinfo:addr ai))
+    ;; Buffer input and output on this port.
+    (setvbuf s _IOFBF)
+    ;; Enlarge the receive buffer.
+    (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+    s))
+
+(define (decode-string bv encoding)
+  (if (string-ci=? encoding "utf-8")
+      (utf8->string bv)
+      (let ((p (open-bytevector-input-port bv)))
+        (set-port-encoding! p encoding)
+        (let ((res (read-delimited "" p)))
+          (close-port p)
+          res))))
+
+(define (text-type? type)
+  (let ((type (symbol->string type)))
+    (or (string-prefix? "text/" type)
+        (string-suffix? "/xml" type)
+        (string-suffix? "+xml" type))))
+
+;; Logically the inverse of (web server)'s `sanitize-response'.
+;;
+(define (decode-response-body response body)
+  ;; `body' is either #f or a bytevector.
+  (cond
+   ((not body) body)
+   ((bytevector? body)
+    (let ((rlen (response-content-length response))
+          (blen (bytevector-length body)))
+      (cond
+       ((and rlen (not (= rlen blen)))
+        (error "bad content-length" rlen blen))
+       ((response-content-type response)
+        => (lambda (type)
+             (cond
+              ((text-type? (car type))
+               (decode-string body (or (assq-ref (cdr type) 'charset)
+                                       "iso-8859-1")))
+              (else body))))
+       (else body))))
+   (else
+    (error "unexpected body type" body))))
+
+(define* (http-get uri #:key (port (open-socket-for-uri uri))
+                   (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
+                   (decode-body? #t))
+  (let ((req (build-request uri #:version version
+                            #:headers (if keep-alive?
+                                          extra-headers
+                                          (cons '(connection close)
+                                                extra-headers)))))
+    (write-request req port)
+    (force-output port)
+    (if (not keep-alive?)
+        (shutdown port 1))
+    (let* ((res (read-response port))
+           (body (read-response-body res)))
+      (if (not keep-alive?)
+          (close-port port))
+      (values res
+              (if decode-body?
+                  (decode-response-body res body)
+                  body)))))
diff --git a/module/web/request.scm b/module/web/request.scm
index 8411920..c9204a4 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -151,21 +151,31 @@
                         (validate-headers? #t))
   "Construct an HTTP request object. If @var{validate-headers?} is true,
 the headers are each run through their respective validators."
-  (cond
-   ((not (and (pair? version)
-              (non-negative-integer? (car version))
-              (non-negative-integer? (cdr version))))
-    (bad-request "Bad version: ~a" version))
-   ((not (uri? uri))
-    (bad-request "Bad uri: ~a" uri))
-   ((and (not port) (memq method '(POST PUT)))
-    (bad-request "Missing port for message ~a" method))
-   ((not (list? meta))
-    (bad-request "Bad metadata alist" meta))
-   (else
-    (if validate-headers?
-        (validate-headers headers))))
-  (make-request method uri version headers meta port))
+  (let ((needs-host? (and (equal? version '(1 . 1))
+                          (not (assq-ref headers 'host)))))
+    (cond
+     ((not (and (pair? version)
+                (non-negative-integer? (car version))
+                (non-negative-integer? (cdr version))))
+      (bad-request "Bad version: ~a" version))
+     ((not (uri? uri))
+      (bad-request "Bad uri: ~a" uri))
+     ((and (not port) (memq method '(POST PUT)))
+      (bad-request "Missing port for message ~a" method))
+     ((not (list? meta))
+      (bad-request "Bad metadata alist" meta))
+     ((and needs-host? (not (uri-host uri)))
+      (bad-request "HTTP/1.1 request without Host header and no host in URI: 
~a"
+                   uri))
+     (else
+      (if validate-headers?
+          (validate-headers headers))))
+    (make-request method uri version
+                  (if needs-host?
+                      (acons 'host (cons (uri-host uri) (uri-port uri))
+                             headers)
+                      headers)
+                  meta port)))
 
 (define* (read-request port #:optional (meta '()))
   "Read an HTTP request from @var{port}, optionally attaching the given
diff --git a/test-suite/tests/web-request.test 
b/test-suite/tests/web-request.test
index e1eec2f..b1182d2 100644
--- a/test-suite/tests/web-request.test
+++ b/test-suite/tests/web-request.test
@@ -47,6 +47,10 @@ Accept-Language: en-gb, en;q=0.9\r
         (set! r (read-request (open-input-string example-1)))
         (request? r)))
     
+    (pass-if (equal?
+              (request-host (build-request (string->uri 
"http://www.gnu.org/";)))
+              "www.gnu.org"))
+    
     (pass-if (equal? (request-method r) 'GET))
     
     (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))


hooks/post-receive
-- 
GNU Guile