[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-114-g99b94
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-114-g99b9434 |
|
Date: |
Wed, 28 Nov 2012 21:57:22 +0000 |
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=99b94347f9c93459e2111e9cacbe3632b8041072
The branch, stable-2.0 has been updated
via 99b94347f9c93459e2111e9cacbe3632b8041072 (commit)
via 91e693a8e8a9d6d7841b189171829ed1c91a01d1 (commit)
via 75d6c59fc25cdcc02f19b626961d46a96bb33234 (commit)
via ee2d874119b898114c6f4b61051cc3c35e1bab38 (commit)
via cb17c4422b6ef005556b7b6fdc137580b6f0e89e (commit)
from c438cd7175540536c3965b4ffea28ae6df7e59e0 (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 99b94347f9c93459e2111e9cacbe3632b8041072
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 22:55:08 2012 +0100
Remove definition of the `SHARED_LIBRARY_PATH_VARIABLE' C macro.
This is a follow-up to fc32c44.
* configure.ac: Remove definition of `SHARED_LIBRARY_PATH_VARIABLE',
which was added in e66ff09a.
commit 91e693a8e8a9d6d7841b189171829ed1c91a01d1
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 22:50:26 2012 +0100
web: Add `http-get*'.
* module/web/client.scm (http-get*): New procedure.
* doc/ref/web.texi (Web Client): Document it.
commit 75d6c59fc25cdcc02f19b626961d46a96bb33234
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 22:26:44 2012 +0100
web: Add `response-body-port'.
* module/web/response.scm (make-delimited-input-port,
response-body-port): New procedures.
(read-response-body): Use `response-body-port'.
* test-suite/tests/web-response.test ("example-1")["response-body-port"]:
New test.
("example-2")["response-body-port"]: New test.
commit ee2d874119b898114c6f4b61051cc3c35e1bab38
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 22:12:59 2012 +0100
web: Export `text-content-type?'.
* module/web/client.scm (text-type?): Remove.
(decode-response-body): Use `text-content-type?'.
* module/web/response.scm (text-content-type?): New procedure.
* doc/ref/web.texi (Responses): Document it.
commit cb17c4422b6ef005556b7b6fdc137580b6f0e89e
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 21:25:07 2012 +0100
tests: Use `pass-if-equal' in `web-response.test'.
* test-suite/tests/web-response.test: Cleanup whitespace. Use
`pass-if-equal' when appropriate.
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 4 --
doc/ref/web.texi | 23 +++++++++
module/web/client.scm | 33 ++++++++++---
module/web/response.scm | 79 +++++++++++++++++++++++++++----
test-suite/tests/web-response.test | 90 ++++++++++++++++++++---------------
5 files changed, 167 insertions(+), 62 deletions(-)
diff --git a/configure.ac b/configure.ac
index 36103df..be20b8c 100644
--- a/configure.ac
+++ b/configure.ac
@@ -79,10 +79,6 @@ AC_PROG_LIBTOOL
AM_CONDITIONAL([HAVE_SHARED_LIBRARIES], [test "x$enable_shared" = "xyes"])
-AC_DEFINE_UNQUOTED([SHARED_LIBRARY_PATH_VARIABLE], ["$shlibpath_var"],
- [Name of the environment variable that tells the dynamic linker where
-to find shared libraries.])
-
dnl Check for libltdl.
AC_LIB_HAVE_LINKFLAGS([ltdl], [], [#include <ltdl.h>],
[lt_dlopenext ("foo");])
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 3e93bea..e892453 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1315,6 +1315,16 @@ Note also, though, that responses to @code{HEAD}
requests must also not
have a body.
@end deffn
address@hidden {Scheme Procedure} response-body-port r [#:decode?=#t]
[#:keep-alive?=#t]
+Return an input port from which the body of @var{r} can be read. The encoding
+of the returned port is set according to @var{r}'s @code{content-type} header,
+when it's textual, except if @var{decode?} is @code{#f}. Return @code{#f}
+when no body is available.
+
+When @var{keep-alive?} is @code{#f}, closing the returned port also closes
address@hidden's response port.
address@hidden deffn
+
@deffn {Scheme Procedure} read-response-body r
Read the response body from @var{r}, as a bytevector. Returns @code{#f}
if there was no response body.
@@ -1361,6 +1371,12 @@ headers.
Return the given response header, or @var{default} if none was present.
@end deffn
address@hidden {Scheme Procedure} text-content-type? @var{type}
+Return @code{#t} if @var{type}, a symbol as returned by
address@hidden, represents a textual type such as
address@hidden/plain}.
address@hidden deffn
+
@node Web Client
@subsection Web Client
@@ -1384,6 +1400,13 @@ response will be decoded to string, if it is a textual
content-type.
Otherwise it will be returned as a bytevector.
@end deffn
address@hidden {Scheme Procedure} http-get* uri [#:port=(open-socket-for-uri
uri)] [#:version='(1 . 1)] [#:keep-alive?=#f] [#:extra-headers='()]
[#:decode-body?=#t]
+Like @code{http-get}, but return an input port from which to read. When
address@hidden is true, as is the default, the returned port has its
+encoding set appropriately if the data at @var{uri} is textual. Closing the
+returned port closes @var{port}, unless @var{keep-alive?} is true.
address@hidden deffn
+
@code{http-get} is useful for making one-off requests to web sites. If
you are writing a web spider or some other client that needs to handle a
number of requests in parallel, it's better to build an event-driven URL
diff --git a/module/web/client.scm b/module/web/client.scm
index 66f2563..df0a749 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -39,7 +39,8 @@
#:use-module (web response)
#:use-module (web uri)
#:export (open-socket-for-uri
- http-get))
+ http-get
+ http-get*))
(define (open-socket-for-uri uri)
"Return an open input/output port for a connection to URI."
@@ -83,12 +84,6 @@
(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)
@@ -104,7 +99,7 @@
((response-content-type response)
=> (lambda (type)
(cond
- ((text-type? (car type))
+ ((text-content-type? (car type))
(decode-string body (or (assq-ref (cdr type) 'charset)
"iso-8859-1")))
(else body))))
@@ -141,3 +136,25 @@ Otherwise it will be returned as a bytevector."
(if decode-body?
(decode-response-body res body)
body)))))
+
+(define* (http-get* uri #:key (port (open-socket-for-uri uri))
+ (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
+ (decode-body? #t))
+ "Like âhttp-getâ, but return an input port from which to read. When
+DECODE-BODY? is true, as is the default, the returned port has its
+encoding set appropriately if the data at URI is textual. Closing the
+returned port closes PORT, unless KEEP-ALIVE? is true."
+ (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)
+ (unless keep-alive?
+ (shutdown port 1))
+ (let* ((res (read-response port))
+ (body (response-body-port res
+ #:keep-alive? keep-alive?
+ #:decode? decode-body?)))
+ (values res body))))
diff --git a/module/web/response.scm b/module/web/response.scm
index aaa7707..5ca7274 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -23,6 +23,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (web http)
#:export (response?
@@ -37,6 +38,7 @@
write-response
response-must-not-include-body?
+ response-body-port
read-response-body
write-response-body
@@ -62,6 +64,7 @@
response-content-md5
response-content-range
response-content-type
+ text-content-type?
response-expires
response-last-modified
@@ -175,6 +178,14 @@ reason phrase for the response's code."
(or (%response-reason-phrase response)
(code->reason-phrase (response-code response))))
+(define (text-content-type? type)
+ "Return #t if TYPE, a symbol as returned by `response-content-type',
+represents a textual type such as `text/plain'."
+ (let ((type (symbol->string type)))
+ (or (string-prefix? "text/" type)
+ (string-suffix? "/xml" type)
+ (string-suffix? "+xml" type))))
+
(define (read-response port)
"Read an HTTP response from PORT.
@@ -224,20 +235,66 @@ This is true for some response types, like those with
code 304."
(= (response-code r) 204)
(= (response-code r) 304)))
+(define (make-delimited-input-port port len keep-alive?)
+ "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT. Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+ (define bytes-read 0)
+
+ (define (fail)
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ bytes-read len))
+
+ (define (read! bv start count)
+ (let ((ret (get-bytevector-n! port bv start count)))
+ (if (eof-object? ret)
+ (if (= bytes-read len)
+ 0
+ (fail))
+ (begin
+ (set! bytes-read (+ bytes-read ret))
+ (if (> bytes-read len)
+ (fail)
+ ret)))))
+
+ (define close
+ (and (not keep-alive?)
+ (lambda ()
+ (close port))))
+
+ (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+(define* (response-body-port r #:key (decode? #t) (keep-alive? #t))
+ "Return an input port from which the body of R can be read. The
+encoding of the returned port is set according to R's âcontent-typeâ
+header, when it's textual, except if DECODE? is #f. Return #f when no
+body is available.
+
+When KEEP-ALIVE? is #f, closing the returned port also closes R's
+response port."
+ (define port
+ (if (member '(chunked) (response-transfer-encoding r))
+ (make-chunked-input-port (response-port r)
+ #:keep-alive? keep-alive?)
+ (let ((len (response-content-length r)))
+ (and len
+ (make-delimited-input-port (response-port r)
+ len keep-alive?)))))
+
+ (when (and decode? port)
+ (match (response-content-type r)
+ (((? text-content-type?) . props)
+ (set-port-encoding! port
+ (or (assq-ref props 'charset)
+ "ISO-8859-1")))
+ (_ #f)))
+
+ port)
+
(define (read-response-body r)
"Reads the response body from R, as a bytevector. Returns
â#fâ if there was no response body."
- (if (member '(chunked) (response-transfer-encoding r))
- (let ((chunk-port (make-chunked-input-port (response-port r)
- #:keep-alive? #t)))
- (get-bytevector-all chunk-port))
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((bv (get-bytevector-n (response-port r) nbytes)))
- (if (= (bytevector-length bv) nbytes)
- bv
- (bad-response "EOF while reading response body: ~a bytes of
~a"
- (bytevector-length bv) nbytes)))))))
+ (and=> (response-body-port r #:decode? #f) get-bytevector-all))
(define (write-response-body r bv)
"Write BV, a bytevector, to the port corresponding to the HTTP
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
index ddd55a7..f9679f5 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding:
utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -21,6 +21,7 @@
#:use-module (web uri)
#:use-module (web response)
#:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:use-module (srfi srfi-19)
#:use-module (test-suite lib))
@@ -66,37 +67,33 @@ consectetur adipisicing elit,\r
(begin
(set! r (read-response (open-input-string example-1)))
(response? r)))
-
+
(pass-if "read-response-body"
(begin
(set! body (read-response-body r))
#t))
-
- (pass-if (equal? (response-version r) '(1 . 1)))
-
- (pass-if (equal? (response-code r) 200))
-
- (pass-if (equal? (response-reason-phrase r) "OK"))
-
- (pass-if (equal? body
- (string->utf8
- "abcdefghijklmnopqrstuvwxyz0123456789")))
-
- (pass-if "checking all headers"
- (equal?
- (response-headers r)
- `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
- "~a, ~d ~b ~Y ~H:~M:~S ~z"))
- (server . "Apache/2.0.55")
- (accept-ranges . (bytes))
- (cache-control . ((max-age . 543234)))
- (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
- "~a, ~d ~b ~Y ~H:~M:~S ~z"))
- (vary . (accept-encoding))
- (content-encoding . (gzip))
- (content-length . 36)
- (content-type . (text/html (charset . "utf-8"))))))
-
+
+ (pass-if-equal '(1 . 1) (response-version r))
+ (pass-if-equal 200 (response-code r))
+ (pass-if-equal "OK" (response-reason-phrase r))
+
+ (pass-if-equal (string->utf8 "abcdefghijklmnopqrstuvwxyz0123456789")
+ body)
+
+ (pass-if-equal "checking all headers"
+ `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (server . "Apache/2.0.55")
+ (accept-ranges . (bytes))
+ (cache-control . ((max-age . 543234)))
+ (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (vary . (accept-encoding))
+ (content-encoding . (gzip))
+ (content-length . 36)
+ (content-type . (text/html (charset . "utf-8"))))
+ (response-headers r))
+
(pass-if "write then read"
(call-with-values
(lambda ()
@@ -111,16 +108,31 @@ consectetur adipisicing elit,\r
(lambda (r* body*)
(responses-equal? r body r* body*))))
- (pass-if "by accessor"
- (equal? (response-content-encoding r) '(gzip)))))
+ (pass-if-equal "by accessor"
+ '(gzip)
+ (response-content-encoding r))
+
+ (pass-if-equal "response-body-port"
+ `("utf-8" ,body)
+ (with-fluids ((%default-port-encoding #f))
+ (let* ((r (read-response (open-input-string example-1)))
+ (p (response-body-port r)))
+ (list (port-encoding p) (get-bytevector-all p)))))))
(with-test-prefix "example-2"
- (let* ((r (read-response (open-input-string example-2)))
- (b (read-response-body r)))
- (pass-if (equal? '((chunked))
- (response-transfer-encoding r)))
- (pass-if (equal? b
- (string->utf8
- (string-append
- "Lorem ipsum dolor sit amet, consectetur adipisicing
elit,"
- " sed do eiusmod tempor incididunt ut labore et dolore
magna aliqua."))))))
+ (let* ((r (read-response (open-input-string example-2)))
+ (b (read-response-body r)))
+ (pass-if-equal '((chunked))
+ (response-transfer-encoding r))
+ (pass-if-equal
+ (string->utf8
+ (string-append
+ "Lorem ipsum dolor sit amet, consectetur adipisicing elit,"
+ " sed do eiusmod tempor incididunt ut labore et dolore magna
aliqua."))
+ b)
+ (pass-if-equal "response-body-port"
+ `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1
+ (with-fluids ((%default-port-encoding #f))
+ (let* ((r (read-response (open-input-string example-2)))
+ (p (response-body-port r)))
+ (list (port-encoding p) (get-string-all p)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-114-g99b9434,
Ludovic Courtès <=