module/web/client.scm

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