module/web/client.scm

   1 ;;; Web client
   2
   3 ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Commentary:
  21 ;;;
  22 ;;; (web client) is a simple HTTP URL fetcher for Guile.
  23 ;;;
  24 ;;; In its current incarnation, (web client) is synchronous.  If you
  25 ;;; want to fetch a number of URLs at once, probably the best thing to
  26 ;;; do is to write an event-driven URL fetcher, similar in structure to
  27 ;;; the web server.
  28 ;;;
  29 ;;; Another option, good but not as performant, would be to use threads,
  30 ;;; possibly via a thread pool.
  31 ;;;
  32 ;;; Code:
  33
  34 (define-module (web client)
  35   #:use-module (rnrs bytevectors)
  36   #:use-module (ice-9 binary-ports)
  37   #:use-module (ice-9 rdelim)
  38   #:use-module (web request)
  39   #:use-module (web response)
  40   #:use-module (web uri)
  41   #:export (open-socket-for-uri
  42             http-get
  43             http-get*))
  44
  45 (define (open-socket-for-uri uri)
  46   "Return an open input/output port for a connection to URI."
  47   (define addresses
  48     (let ((port (uri-port uri)))
  49       (getaddrinfo (uri-host uri)
  50                    (cond (port => number->string)
  51                          (else (symbol->string (uri-scheme uri))))
  52                    (if port
  53                        AI_NUMERICSERV
  54                        0))))
  55
  56   (let loop ((addresses addresses))
  57     (let* ((ai (car addresses))
  58            (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
  59                        (addrinfo:protocol ai))))
  60       (set-port-encoding! s "ISO-8859-1")
  61
  62       (catch 'system-error
  63         (lambda ()
  64           (connect s (addrinfo:addr ai))
  65
  66           ;; Buffer input and output on this port.
  67           (setvbuf s _IOFBF)
  68           ;; Enlarge the receive buffer.
  69           (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
  70           s)
  71         (lambda args
  72           ;; Connection failed, so try one of the other addresses.
  73           (close s)
  74           (if (null? addresses)
  75               (apply throw args)
  76               (loop (cdr addresses))))))))
  77
  78 (define (decode-string bv encoding)
  79   (if (string-ci=? encoding "utf-8")
  80       (utf8->string bv)
  81       (let ((p (open-bytevector-input-port bv)))
  82         (set-port-encoding! p encoding)
  83         (let ((res (read-delimited "" p)))
  84           (close-port p)
  85           res))))
  86
  87 ;; Logically the inverse of (web server)'s `sanitize-response'.
  88 ;;
  89 (define (decode-response-body response body)
  90   ;; `body' is either #f or a bytevector.
  91   (cond
  92    ((not body) body)
  93    ((bytevector? body)
  94     (let ((rlen (response-content-length response))
  95           (blen (bytevector-length body)))
  96       (cond
  97        ((and rlen (not (= rlen blen)))
  98         (error "bad content-length" rlen blen))
  99        ((response-content-type response)
 100         => (lambda (type)
 101              (cond
 102               ((text-content-type? (car type))
 103                (decode-string body (or (assq-ref (cdr type) 'charset)
 104                                        "iso-8859-1")))
 105               (else body))))
 106        (else body))))
 107    (else
 108     (error "unexpected body type" body))))
 109
 110 (define* (http-get uri #:key (port (open-socket-for-uri uri))
 111                    (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
 112                    (decode-body? #t))
 113   "Connect to the server corresponding to URI and ask for the
 114 resource, using the ‘GET’ method.  If you already have a port open,
 115 pass it as PORT.  The port will be closed at the end of the
 116 request unless KEEP-ALIVE? is true.  Any extra headers in the
 117 alist EXTRA-HEADERS will be added to the request.
 118
 119 If DECODE-BODY? is true, as is the default, the body of the
 120 response will be decoded to string, if it is a textual content-type.
 121 Otherwise it will be returned as a bytevector."
 122   (let ((req (build-request uri #:version version
 123                             #:headers (if keep-alive?
 124                                           extra-headers
 125                                           (cons '(connection close)
 126                                                 extra-headers)))))
 127     (write-request req port)
 128     (force-output port)
 129     (if (not keep-alive?)
 130         (shutdown port 1))
 131     (let* ((res (read-response port))
 132            (body (read-response-body res)))
 133       (if (not keep-alive?)
 134           (close-port port))
 135       (values res
 136               (if decode-body?
 137                   (decode-response-body res body)
 138                   body)))))
 139
 140 (define* (http-get* uri #:key (port (open-socket-for-uri uri))
 141                     (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
 142                     (decode-body? #t))
 143   "Like ‘http-get’, but return an input port from which to read.  When
 144 DECODE-BODY? is true, as is the default, the returned port has its
 145 encoding set appropriately if the data at URI is textual.  Closing the
 146 returned port closes PORT, unless KEEP-ALIVE? is true."
 147   (let ((req (build-request uri #:version version
 148                             #:headers (if keep-alive?
 149                                           extra-headers
 150                                           (cons '(connection close)
 151                                                 extra-headers)))))
 152     (write-request req port)
 153     (force-output port)
 154     (unless keep-alive?
 155       (shutdown port 1))
 156     (let* ((res (read-response port))
 157            (body (response-body-port res
 158                                      #:keep-alive? keep-alive?
 159                                      #:decode? decode-body?)))
 160       (values res body))))