module/web/client.scm

   1 ;;; Web client
   2
   3 ;; Copyright (C) 2011 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 par-map or futures.
  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
  44 (define (open-socket-for-uri uri)
  45   (let* ((ai (car (getaddrinfo (uri-host uri)
  46                                (cond
  47                                 ((uri-port uri) => number->string)
  48                                 (else (symbol->string (uri-scheme uri)))))))
  49          (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
  50                      (addrinfo:protocol ai))))
  51     (set-port-encoding! s "ISO-8859-1")
  52     (connect s (addrinfo:addr ai))
  53     ;; Buffer input and output on this port.
  54     (setvbuf s _IOFBF)
  55     ;; Enlarge the receive buffer.
  56     (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
  57     s))
  58
  59 (define (decode-string bv encoding)
  60   (if (string-ci=? encoding "utf-8")
  61       (utf8->string bv)
  62       (let ((p (open-bytevector-input-port bv)))
  63         (set-port-encoding! p encoding)
  64         (let ((res (read-delimited "" p)))
  65           (close-port p)
  66           res))))
  67
  68 (define (text-type? type)
  69   (let ((type (symbol->string type)))
  70     (or (string-prefix? "text/" type)
  71         (string-suffix? "/xml" type)
  72         (string-suffix? "+xml" type))))
  73
  74 ;; Logically the inverse of (web server)'s `sanitize-response'.
  75 ;;
  76 (define (decode-response-body response body)
  77   ;; `body' is either #f or a bytevector.
  78   (cond
  79    ((not body) body)
  80    ((bytevector? body)
  81     (let ((rlen (response-content-length response))
  82           (blen (bytevector-length body)))
  83       (cond
  84        ((and rlen (not (= rlen blen)))
  85         (error "bad content-length" rlen blen))
  86        ((response-content-type response)
  87         => (lambda (type)
  88              (cond
  89               ((text-type? (car type))
  90                (decode-string body (or (assq-ref (cdr type) 'charset)
  91                                        "iso-8859-1")))
  92               (else body))))
  93        (else body))))
  94    (else
  95     (error "unexpected body type" body))))
  96
  97 (define* (http-get uri #:key (port (open-socket-for-uri uri))
  98                    (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
  99                    (decode-body? #t))
 100   (let ((req (build-request uri #:version version
 101                             #:headers (if keep-alive?
 102                                           extra-headers
 103                                           (cons '(connection close)
 104                                                 extra-headers)))))
 105     (write-request req port)
 106     (force-output port)
 107     (if (not keep-alive?)
 108         (shutdown port 1))
 109     (let* ((res (read-response port))
 110            (body (read-response-body res)))
 111       (if (not keep-alive?)
 112           (close-port port))
 113       (values res
 114               (if decode-body?
 115                   (decode-response-body res body)
 116                   body)))))