guix/http-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
   5 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix http-client)
  23   #:use-module (web uri)
  24   #:use-module (web http)
  25   #:use-module ((web client) #:hide (open-socket-for-uri))
  26   #:use-module (web request)
  27   #:use-module (web response)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-19)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 binary-ports)
  36   #:use-module (rnrs bytevectors)
  37   #:use-module (guix ui)
  38   #:use-module (guix utils)
  39   #:use-module (guix base64)
  40   #:autoload   (gcrypt hash) (sha256)
  41   #:autoload   (gnutls) (error/invalid-session)
  42   #:use-module ((guix build utils)
  43                 #:select (mkdir-p dump-port))
  44   #:use-module ((guix build download)
  45                 #:select (open-socket-for-uri
  46                           (open-connection-for-uri
  47                            . guix:open-connection-for-uri)
  48                           resolve-uri-reference))
  49   #:re-export (open-socket-for-uri)
  50   #:export (&http-get-error
  51             http-get-error?
  52             http-get-error-uri
  53             http-get-error-code
  54             http-get-error-reason
  55
  56             http-fetch
  57             http-multiple-get
  58
  59             %http-cache-ttl
  60             http-fetch/cached))
  61
  62 ;;; Commentary:
  63 ;;;
  64 ;;; HTTP client portable among Guile versions, and with proper error condition
  65 ;;; reporting.
  66 ;;;
  67 ;;; Code:
  68
  69 ;; HTTP GET error.
  70 (define-condition-type &http-get-error &error
  71   http-get-error?
  72   (uri    http-get-error-uri)                     ; URI
  73   (code   http-get-error-code)                    ; integer
  74   (reason http-get-error-reason))                 ; string
  75
  76
  77 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
  78                      (open-connection guix:open-connection-for-uri)
  79                      (keep-alive? #f)
  80                      (verify-certificate? #t)
  81                      (headers '((user-agent . "GNU Guile")))
  82                      (log-port (current-error-port))
  83                      timeout)
  84   "Return an input port containing the data at URI, and the expected number of
  85 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
  86 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
  87 unbuffered port, suitable for use in `filtered-port'.  HEADERS is an alist of
  88 extra HTTP headers.
  89
  90 When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is
  91 not closed upon completion.
  92
  93 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
  94
  95 TIMEOUT specifies the timeout in seconds for connection establishment; when
  96 TIMEOUT is #f, connection establishment never times out.
  97
  98 Write information about redirects to LOG-PORT.
  99
 100 Raise an '&http-get-error' condition if downloading fails."
 101   (let loop ((uri (if (string? uri)
 102                       (string->uri uri)
 103                       uri)))
 104     (let ((port (or port (open-connection uri
 105                                           #:verify-certificate?
 106                                           verify-certificate?
 107                                           #:timeout timeout)))
 108           (headers (match (uri-userinfo uri)
 109                      ((? string? str)
 110                       (cons (cons 'Authorization
 111                                   (string-append "Basic "
 112                                                  (base64-encode
 113                                                   (string->utf8 str))))
 114                             headers))
 115                      (_ headers))))
 116       (unless (or buffered? (not (file-port? port)))
 117         (setvbuf port 'none))
 118       (let*-values (((resp data)
 119                      (http-get uri #:streaming? #t #:port port
 120                                #:keep-alive? keep-alive?
 121                                #:headers headers))
 122                     ((code)
 123                      (response-code resp)))
 124         (case code
 125           ((200)
 126            (values data (response-content-length resp)))
 127           ((301                                   ; moved permanently
 128             302                                   ; found (redirection)
 129             303                                   ; see other
 130             307                                   ; temporary redirection
 131             308)                                  ; permanent redirection
 132            (let ((uri (resolve-uri-reference (response-location resp) uri)))
 133              (close-port port)
 134              (format log-port (G_ "following redirection to `~a'...~%")
 135                      (uri->string uri))
 136              (loop uri)))
 137           (else
 138            (raise (condition (&http-get-error
 139                               (uri uri)
 140                               (code code)
 141                               (reason (response-reason-phrase resp)))
 142                              (&message
 143                               (message
 144                                (format
 145                                 #f
 146                                 (G_ "~a: HTTP download failed: ~a (~s)")
 147                                 (uri->string uri) code
 148                                 (response-reason-phrase resp))))))))))))
 149
 150 (define-syntax-rule (false-if-networking-error exp)
 151   "Return #f if EXP triggers a network related exception as can occur when
 152 reusing stale cached connections."
 153   ;; FIXME: Duplicated from 'with-cached-connection'.
 154   (catch #t
 155     (lambda ()
 156       exp)
 157     (lambda (key . args)
 158       ;; If PORT was cached and the server closed the connection in the
 159       ;; meantime, we get EPIPE.  In that case, open a fresh connection and
 160       ;; retry.  We might also get 'bad-response or a similar exception from
 161       ;; (web response) later on, once we've sent the request, or a
 162       ;; ERROR/INVALID-SESSION from GnuTLS.
 163       (if (or (and (eq? key 'system-error)
 164                    (= EPIPE (system-error-errno `(,key ,@args))))
 165               (and (eq? key 'gnutls-error)
 166                    (eq? (first args) error/invalid-session))
 167               (memq key
 168                     '(bad-response bad-header bad-header-component)))
 169           #f
 170           (apply throw key args)))))
 171
 172 (define* (http-multiple-get base-uri proc seed requests
 173                             #:key port (verify-certificate? #t)
 174                             (open-connection guix:open-connection-for-uri)
 175                             (keep-alive? #t)
 176                             (batch-size 1000))
 177   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
 178 response, passing it the request object, the response, a port from which to
 179 read the response body, and the previous result, starting with SEED, à la
 180 'fold'.  Return the final result.
 181
 182 When PORT is specified, use it as the initial connection on which HTTP
 183 requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
 184 a URI.  When KEEP-ALIVE? is false, close the connection port before
 185 returning."
 186   (let connect ((port     port)
 187                 (requests requests)
 188                 (result   seed))
 189     (define batch
 190       (if (>= batch-size (length requests))
 191           requests
 192           (take requests batch-size)))
 193
 194     ;; (format (current-error-port) "connecting (~a requests left)..."
 195     ;;         (length requests))
 196     (let ((p (or port (open-connection base-uri
 197                                        #:verify-certificate?
 198                                        verify-certificate?))))
 199       ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
 200       (when (file-port? p)
 201         (setvbuf p 'block (expt 2 16)))
 202
 203       ;; Send BATCH in a row.
 204       ;; XXX: Do our own caching to work around inefficiencies when
 205       ;; communicating over TLS: <http://bugs.gnu.org/22966>.
 206       (let-values (((buffer get) (open-bytevector-output-port)))
 207         ;; Inherit the HTTP proxying property from P.
 208         (set-http-proxy-port?! buffer (http-proxy-port? p))
 209
 210         (unless (false-if-networking-error
 211                  (begin
 212                    (for-each (cut write-request <> buffer) batch)
 213                    (put-bytevector p (get))
 214                    (force-output p)
 215                    #t))
 216           ;; If PORT becomes unusable, open a fresh connection and retry.
 217           (close-port p)                          ; close the broken port
 218           (connect #f requests result)))
 219
 220       ;; Now start processing responses.
 221       (let loop ((sent      batch)
 222                  (processed 0)
 223                  (result    result))
 224         (match sent
 225           (()
 226            (match (drop requests processed)
 227              (()
 228               (unless keep-alive?
 229                 (close-port p))
 230               (reverse result))
 231              (remainder
 232               (connect p remainder result))))
 233           ((head tail ...)
 234            (match (false-if-networking-error (read-response p))
 235              ((? response? resp)
 236               (let* ((body   (response-body-port resp))
 237                      (result (proc head resp body result)))
 238                 ;; The server can choose to stop responding at any time,
 239                 ;; in which case we have to try again.  Check whether
 240                 ;; that is the case.  Note that even upon "Connection:
 241                 ;; close", we can read from BODY.
 242                 (match (assq 'connection (response-headers resp))
 243                   (('connection 'close)
 244                    (close-port p)
 245                    (connect #f                    ;try again
 246                             (drop requests (+ 1 processed))
 247                             result))
 248                   (_
 249                    (loop tail (+ 1 processed) result)))))
 250              (#f
 251               (close-port p)
 252               (connect #f                         ; try again
 253                        (drop requests processed)
 254                        result)))))))))
 255
 256 \f
 257 ;;;
 258 ;;; Caching.
 259 ;;;
 260
 261 (define %http-cache-ttl
 262   ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
 263   (make-parameter
 264    (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
 265                       string->number*)
 266                36))))
 267
 268 (define (cache-file-for-uri uri)
 269   "Return the name of the file in the cache corresponding to URI."
 270   (let ((digest (sha256 (string->utf8 (uri->string uri)))))
 271     ;; Use the "URL" alphabet because it does not contain "/".
 272     (string-append (cache-directory) "/http/"
 273                    (base64-encode digest 0 (bytevector-length digest)
 274                                   #f #f base64url-alphabet))))
 275
 276 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
 277                             (write-cache dump-port)
 278                             (cache-miss (const #t))
 279                             (log-port (current-error-port))
 280                             (timeout 10))
 281   "Like 'http-fetch', return an input port, but cache its contents in
 282 ~/.cache/guix.  The cache remains valid for TTL seconds.
 283
 284 Call WRITE-CACHE with the HTTP input port and the cache output port to write
 285 the data to cache.  Call CACHE-MISS with URI just before fetching data from
 286 URI.
 287
 288 TIMEOUT specifies the timeout in seconds for connection establishment.
 289
 290 Write information about redirects to LOG-PORT."
 291   (let ((file (cache-file-for-uri uri)))
 292     (define (update-cache cache-port)
 293       (define cache-time
 294         (and cache-port
 295              (stat:mtime (stat cache-port))))
 296
 297       (define headers
 298         `((user-agent . "GNU Guile")
 299           ,@(if cache-time
 300                 `((if-modified-since
 301                    . ,(time-utc->date (make-time time-utc 0 cache-time))))
 302                 '())))
 303
 304       ;; Update the cache and return an input port.
 305       (guard (c ((http-get-error? c)
 306                  (if (= 304 (http-get-error-code c)) ;"Not Modified"
 307                      (begin
 308                        (utime file)               ;update FILE's mtime
 309                        cache-port)
 310                      (raise c))))
 311         (let ((port (http-fetch uri #:text? text?
 312                                 #:log-port log-port
 313                                 #:headers headers #:timeout timeout)))
 314           (cache-miss uri)
 315           (mkdir-p (dirname file))
 316           (when cache-port
 317             (close-port cache-port))
 318           (with-atomic-file-output file
 319             (cut write-cache port <>))
 320           (close-port port)
 321           (open-input-file file))))
 322
 323     (define (old? port)
 324       ;; Return true if PORT has passed TTL.
 325       (let* ((s   (stat port))
 326              (now (current-time time-utc)))
 327         (< (+ (stat:mtime s) ttl) (time-second now))))
 328
 329     (catch 'system-error
 330       (lambda ()
 331         (let ((port (open-input-file file)))
 332           (if (old? port)
 333               (update-cache port)
 334               port)))
 335       (lambda args
 336         (if (= ENOENT (system-error-errno args))
 337             (update-cache #f)
 338             (apply throw args))))))
 339
 340 ;;; http-client.scm ends here