module/web/client.scm

   1 ;;; Web client
   2
   3 ;; Copyright (C) 2011, 2012, 2013 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 iconv)
  38   #:use-module (ice-9 rdelim)
  39   #:use-module (web request)
  40   #:use-module (web response)
  41   #:use-module (web uri)
  42   #:use-module (srfi srfi-1)
  43   #:export (open-socket-for-uri
  44             http-get
  45             http-get*
  46             http-head
  47             http-post
  48             http-put
  49             http-delete
  50             http-trace
  51             http-options))
  52
  53 (define (ensure-uri uri-or-string)
  54   (cond
  55    ((string? uri-or-string) (string->uri uri-or-string))
  56    ((uri? uri-or-string) uri-or-string)
  57    (else (error "Invalid URI" uri-or-string))))
  58
  59 (define (open-socket-for-uri uri-or-string)
  60   "Return an open input/output port for a connection to URI."
  61   (define uri (ensure-uri uri-or-string))
  62   (define addresses
  63     (let ((port (uri-port uri)))
  64       (delete-duplicates
  65        (getaddrinfo (uri-host uri)
  66                     (cond (port => number->string)
  67                           (else (symbol->string (uri-scheme uri))))
  68                     (if port
  69                         AI_NUMERICSERV
  70                         0))
  71        (lambda (ai1 ai2)
  72          (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
  73
  74   (let loop ((addresses addresses))
  75     (let* ((ai (car addresses))
  76            (s  (with-fluids ((%default-port-encoding #f))
  77                  ;; Restrict ourselves to TCP.
  78                  (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
  79       (catch 'system-error
  80         (lambda ()
  81           (connect s (addrinfo:addr ai))
  82
  83           ;; Buffer input and output on this port.
  84           (setvbuf s _IOFBF)
  85           ;; Enlarge the receive buffer.
  86           (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
  87           s)
  88         (lambda args
  89           ;; Connection failed, so try one of the other addresses.
  90           (close s)
  91           (if (null? (cdr addresses))
  92               (apply throw args)
  93               (loop (cdr addresses))))))))
  94
  95 (define (extend-request r k v . additional)
  96   (let ((r (build-request (request-uri r) #:version (request-version r)
  97                           #:headers
  98                           (assoc-set! (copy-tree (request-headers r))
  99                                       k v)
 100                           #:port (request-port r))))
 101     (if (null? additional)
 102         r
 103         (apply extend-request r additional))))
 104
 105 ;; -> request body
 106 (define (sanitize-request request body)
 107   "\"Sanitize\" the given request and body, ensuring that they are
 108 complete and coherent.  This method is most useful for methods that send
 109 data to the server, like POST, but can be used for any method.  Return
 110 two values: a request and a bytevector, possibly the same ones that were
 111 passed as arguments.
 112
 113 If BODY is a string, encodes the string to a bytevector, in an encoding
 114 appropriate for REQUEST.  Adds a ‘content-length’ and ‘content-type’
 115 header, as necessary.
 116
 117 If BODY is a procedure, it is called with a port as an argument, and the
 118 output collected as a bytevector.  In the future we might try to instead
 119 use a compressing, chunk-encoded port, and call this procedure later.
 120 Authors are advised not to rely on the procedure being called at any
 121 particular time.
 122
 123 Note that we rely on the request itself already having been validated,
 124 as is the case by default with a request returned by `build-request'."
 125   (cond
 126    ((not body)
 127     (let ((length (request-content-length request)))
 128       (if length
 129           (unless (zero? length)
 130             (error "content-length, but no body"))
 131           (when (assq 'transfer-encoding (request-headers request))
 132             (error "transfer-encoding not allowed with no body")))
 133       (values request #vu8())))
 134    ((string? body)
 135     (let* ((type (request-content-type request '(text/plain)))
 136            (declared-charset (assq-ref (cdr type) 'charset))
 137            (charset (or declared-charset "utf-8")))
 138       (sanitize-request
 139        (if declared-charset
 140            request
 141            (extend-request request 'content-type
 142                             `(,@type (charset . ,charset))))
 143        (string->bytevector body charset))))
 144    ((procedure? body)
 145     (let* ((type (request-content-type request
 146                                         '(text/plain)))
 147            (declared-charset (assq-ref (cdr type) 'charset))
 148            (charset (or declared-charset "utf-8")))
 149       (sanitize-request
 150        (if declared-charset
 151            request
 152            (extend-request request 'content-type
 153                             `(,@type (charset . ,charset))))
 154        (call-with-encoded-output-string charset body))))
 155    ((not (bytevector? body))
 156     (error "unexpected body type"))
 157    (else
 158     (values (let ((rlen (request-content-length request))
 159                   (blen (bytevector-length body)))
 160               (cond
 161                (rlen (if (= rlen blen)
 162                          request
 163                          (error "bad content-length" rlen blen)))
 164                ((zero? blen) request)
 165                (else (extend-request request 'content-length blen))))
 166             body))))
 167
 168 (define (decode-response-body response body)
 169   ;; `body' is either #f or a bytevector.
 170   (cond
 171    ((not body) body)
 172    ((bytevector? body)
 173     (let ((rlen (response-content-length response))
 174           (blen (bytevector-length body)))
 175       (cond
 176        ((and rlen (not (= rlen blen)))
 177         (error "bad content-length" rlen blen))
 178        ((response-content-type response)
 179         => (lambda (type)
 180              (cond
 181               ((text-content-type? (car type))
 182                ;; RFC 2616 3.7.1: "When no explicit charset parameter is
 183                ;; provided by the sender, media subtypes of the "text"
 184                ;; type are defined to have a default charset value of
 185                ;; "ISO-8859-1" when received via HTTP."
 186                (bytevector->string body (or (assq-ref (cdr type) 'charset)
 187                                             "iso-8859-1")))
 188               (else body))))
 189        (else body))))
 190    (else
 191     (error "unexpected body type" body))))
 192
 193 ;; We could expose this to user code if there is demand.
 194 (define* (request uri #:key
 195                   (body #f)
 196                   (port (open-socket-for-uri uri))
 197                   (method "GET")
 198                   (version '(1 . 1))
 199                   (keep-alive? #f)
 200                   (headers '())
 201                   (decode-body? #t)
 202                   (streaming? #f)
 203                   (request
 204                    (build-request
 205                     (ensure-uri uri)
 206                     #:method method
 207                     #:version version
 208                     #:headers (if keep-alive?
 209                                   headers
 210                                   (cons '(connection close) headers))
 211                     #:port port)))
 212   (call-with-values (lambda () (sanitize-request request body))
 213     (lambda (request body)
 214       (let ((request (write-request request port)))
 215         (when body
 216           (write-request-body request body))
 217         (force-output (request-port request))
 218         (let ((response (read-response port)))
 219           (cond
 220            ((equal? (request-method request) "HEAD")
 221             (unless keep-alive?
 222               (close-port port))
 223             (values response #f))
 224            (streaming?
 225             (values response
 226                     (response-body-port response
 227                                         #:keep-alive? keep-alive?
 228                                         #:decode? decode-body?)))
 229            (else
 230             (let ((body (read-response-body response)))
 231               (unless keep-alive?
 232                 (close-port port))
 233               (values response
 234                       (if decode-body?
 235                           (decode-response-body response body)
 236                           body))))))))))
 237
 238 (define* (http-get uri #:key
 239                    (body #f)
 240                    (port (open-socket-for-uri uri))
 241                    (version '(1 . 1)) (keep-alive? #f)
 242                    ;; #:headers is the new name of #:extra-headers.
 243                    (extra-headers #f) (headers (or extra-headers '()))
 244                    (decode-body? #t) (streaming? #f))
 245   "Connect to the server corresponding to URI and ask for the
 246 resource, using the ‘GET’ method.  If you already have a port open,
 247 pass it as PORT.  The port will be closed at the end of the
 248 request unless KEEP-ALIVE? is true.  Any extra headers in the
 249 alist HEADERS will be added to the request.
 250
 251 If BODY is not #f, a message body will also be sent with the HTTP
 252 request.  If BODY is a string, it is encoded according to the
 253 content-type in HEADERS, defaulting to UTF-8.  Otherwise BODY should be
 254 a bytevector, or #f for no body.  Although it's allowed to send a
 255 message body along with any request, usually only POST and PUT requests
 256 have bodies.  See ‘http-put’ and ‘http-post’ documentation, for more.
 257
 258 If DECODE-BODY? is true, as is the default, the body of the
 259 response will be decoded to string, if it is a textual content-type.
 260 Otherwise it will be returned as a bytevector.
 261
 262 However, if STREAMING? is true, instead of eagerly reading the response
 263 body from the server, this function only reads off the headers.  The
 264 response body will be returned as a port on which the data may be read.
 265 Unless KEEP-ALIVE? is true, the port will be closed after the full
 266 response body has been read.
 267
 268 Returns two values: the response read from the server, and the response
 269 body as a string, bytevector, #f value, or as a port (if STREAMING? is
 270 true)."
 271   (when extra-headers
 272     (issue-deprecation-warning
 273      "The #:extra-headers argument to http-get has been renamed to #:headers. "
 274      "Please update your code."))
 275   (request uri #:method "GET" #:body body
 276            #:port port #:version version #:keep-alive? keep-alive?
 277            #:headers headers #:decode-body? decode-body?
 278            #:streaming? streaming?))
 279
 280 (define* (http-get* uri #:key
 281                     (body #f)
 282                     (port (open-socket-for-uri uri))
 283                     (version '(1 . 1)) (keep-alive? #f)
 284                     ;; #:headers is the new name of #:extra-headers.
 285                     (extra-headers #f) (headers (or extra-headers '()))
 286                     (decode-body? #t))
 287   "Deprecated in favor of (http-get #:streaming? #t)."
 288   (when extra-headers
 289     (issue-deprecation-warning
 290      "`http-get*' has been deprecated.  "
 291      "Instead, use `http-get' with the #:streaming? #t keyword argument."))
 292   (http-get uri #:body body
 293             #:port port #:version version #:keep-alive? keep-alive?
 294             #:headers headers #:decode-body? #t #:streaming? #t))
 295
 296 (define-syntax-rule (define-http-verb http-verb method doc)
 297   (define* (http-verb uri #:key
 298                       (body #f)
 299                       (port (open-socket-for-uri uri))
 300                       (version '(1 . 1))
 301                       (keep-alive? #f)
 302                       (headers '())
 303                       (decode-body? #t)
 304                       (streaming? #f))
 305     doc
 306     (request uri
 307              #:body body #:method method
 308              #:port port #:version version #:keep-alive? keep-alive?
 309              #:headers headers #:decode-body? decode-body?
 310              #:streaming? streaming?)))
 311
 312 (define-http-verb http-head
 313   "HEAD"
 314   "Fetch message headers for the given URI using the HTTP \"HEAD\"
 315 method.
 316
 317 This function is similar to ‘http-get’, except it uses the \"HEAD\"
 318 method.  See ‘http-get’ for full documentation on the various keyword
 319 arguments that are accepted by this function.
 320
 321 Returns two values: the resulting response, and #f.  Responses to HEAD
 322 requests do not have a body.  The second value is only returned so that
 323 other procedures can treat all of the http-foo verbs identically.")
 324
 325 (define-http-verb http-post
 326   "POST"
 327   "Post data to the given URI using the HTTP \"POST\" method.
 328
 329 This function is similar to ‘http-get’, except it uses the \"POST\"
 330 method.  See ‘http-get’ for full documentation on the various keyword
 331 arguments that are accepted by this function.
 332
 333 Returns two values: the resulting response, and the response body.")
 334
 335 (define-http-verb http-put
 336   "PUT"
 337   "Put data at the given URI using the HTTP \"PUT\" method.
 338
 339 This function is similar to ‘http-get’, except it uses the \"PUT\"
 340 method.  See ‘http-get’ for full documentation on the various keyword
 341 arguments that are accepted by this function.
 342
 343 Returns two values: the resulting response, and the response body.")
 344
 345 (define-http-verb http-delete
 346   "DELETE"
 347   "Delete data at the given URI using the HTTP \"DELETE\" method.
 348
 349 This function is similar to ‘http-get’, except it uses the \"DELETE\"
 350 method.  See ‘http-get’ for full documentation on the various keyword
 351 arguments that are accepted by this function.
 352
 353 Returns two values: the resulting response, and the response body.")
 354
 355 (define-http-verb http-trace
 356   "TRACE"
 357   "Send an HTTP \"TRACE\" request.
 358
 359 This function is similar to ‘http-get’, except it uses the \"TRACE\"
 360 method.  See ‘http-get’ for full documentation on the various keyword
 361 arguments that are accepted by this function.
 362
 363 Returns two values: the resulting response, and the response body.")
 364
 365 (define-http-verb http-options
 366   "OPTIONS"
 367   "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\"
 368 method.
 369
 370 This function is similar to ‘http-get’, except it uses the \"OPTIONS\"
 371 method.  See ‘http-get’ for full documentation on the various keyword
 372 arguments that are accepted by this function.
 373
 374 Returns two values: the resulting response, and the response body.")