diff options
author | Andy Wingo <wingo@pobox.com> | 2011-07-25 18:26:37 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-07-25 18:26:37 +0200 |
commit | ab4bc85398a14b62b58694bab83c63be286b2fd5 (patch) | |
tree | 84bfe7b0b6064016bcfadb76ec95d07410654fe8 /module/web | |
parent | f29c300507da21a667f5b82e75300f8009eab9cc (diff) | |
parent | f4b7d918eff9770f09893b023fd834f5c0bc33d1 (diff) | |
download | guile-ab4bc85398a14b62b58694bab83c63be286b2fd5.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
test-suite/tests/srfi-4.test
Diffstat (limited to 'module/web')
-rw-r--r-- | module/web/client.scm | 116 | ||||
-rw-r--r-- | module/web/request.scm | 40 |
2 files changed, 141 insertions, 15 deletions
diff --git a/module/web/client.scm b/module/web/client.scm new file mode 100644 index 000000000..6a04497cf --- /dev/null +++ b/module/web/client.scm @@ -0,0 +1,116 @@ +;;; 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)))) + (set-port-encoding! s "ISO-8859-1") + (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 84119205f..c9204a4bf 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 |