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