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 error/again error/interrupted)
  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                    (memq (first args)
 167                          (list error/invalid-session
 168
 169                                ;; XXX: These two are not properly handled in
 170                                ;; GnuTLS < 3.7.2, in
 171                                ;; 'write_to_session_record_port'; see
 172                                ;; <https://bugs.gnu.org/47867>.
 173                                error/again error/interrupted)))
 174               (memq key
 175                     '(bad-response bad-header bad-header-component)))
 176           #f
 177           (apply throw key args)))))
 178
 179 (define* (http-multiple-get base-uri proc seed requests
 180                             #:key port (verify-certificate? #t)
 181                             (open-connection guix:open-connection-for-uri)
 182                             (keep-alive? #t)
 183                             (batch-size 1000))
 184   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
 185 response, passing it the request object, the response, a port from which to
 186 read the response body, and the previous result, starting with SEED, à la
 187 'fold'.  Return the final result.
 188
 189 When PORT is specified, use it as the initial connection on which HTTP
 190 requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
 191 a URI.  When KEEP-ALIVE? is false, close the connection port before
 192 returning."
 193   (let connect ((port     port)
 194                 (requests requests)
 195                 (result   seed))
 196     (define batch
 197       (if (>= batch-size (length requests))
 198           requests
 199           (take requests batch-size)))
 200
 201     ;; (format (current-error-port) "connecting (~a requests left)..."
 202     ;;         (length requests))
 203     (let ((p (or port (open-connection base-uri
 204                                        #:verify-certificate?
 205                                        verify-certificate?))))
 206       ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
 207       (when (file-port? p)
 208         (setvbuf p 'block (expt 2 16)))
 209
 210       ;; Send BATCH in a row.
 211       ;; XXX: Do our own caching to work around inefficiencies when
 212       ;; communicating over TLS: <http://bugs.gnu.org/22966>.
 213       (let-values (((buffer get) (open-bytevector-output-port)))
 214         ;; Inherit the HTTP proxying property from P.
 215         (set-http-proxy-port?! buffer (http-proxy-port? p))
 216
 217         ;; Swallow networking errors that could occur due to connection reuse
 218         ;; and the like; they will be handled down the road when trying to
 219         ;; read responses.
 220         (false-if-networking-error
 221          (begin
 222            (for-each (cut write-request <> buffer) batch)
 223            (put-bytevector p (get))
 224            (force-output p))))
 225
 226       ;; Now start processing responses.
 227       (let loop ((sent      batch)
 228                  (processed 0)
 229                  (result    result))
 230         (match sent
 231           (()
 232            (match (drop requests processed)
 233              (()
 234               (unless keep-alive?
 235                 (close-port p))
 236               (reverse result))
 237              (remainder
 238               (connect p remainder result))))
 239           ((head tail ...)
 240            (match (false-if-networking-error (read-response p))
 241              ((? response? resp)
 242               (let* ((body   (response-body-port resp))
 243                      (result (proc head resp body result)))
 244                 ;; The server can choose to stop responding at any time,
 245                 ;; in which case we have to try again.  Check whether
 246                 ;; that is the case.  Note that even upon "Connection:
 247                 ;; close", we can read from BODY.
 248                 (match (assq 'connection (response-headers resp))
 249                   (('connection 'close)
 250                    (close-port p)
 251                    (connect #f                    ;try again
 252                             (drop requests (+ 1 processed))
 253                             result))
 254                   (_
 255                    (loop tail (+ 1 processed) result)))))
 256              (#f
 257               (close-port p)
 258               (connect #f                         ; try again
 259                        (drop requests processed)
 260                        result)))))))))
 261
 262 \f
 263 ;;;
 264 ;;; Caching.
 265 ;;;
 266
 267 (define %http-cache-ttl
 268   ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
 269   (make-parameter
 270    (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
 271                       string->number*)
 272                36))))
 273
 274 (define (cache-file-for-uri uri)
 275   "Return the name of the file in the cache corresponding to URI."
 276   (let ((digest (sha256 (string->utf8 (uri->string uri)))))
 277     ;; Use the "URL" alphabet because it does not contain "/".
 278     (string-append (cache-directory) "/http/"
 279                    (base64-encode digest 0 (bytevector-length digest)
 280                                   #f #f base64url-alphabet))))
 281
 282 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
 283                             (write-cache dump-port)
 284                             (cache-miss (const #t))
 285                             (log-port (current-error-port))
 286                             (timeout 10))
 287   "Like 'http-fetch', return an input port, but cache its contents in
 288 ~/.cache/guix.  The cache remains valid for TTL seconds.
 289
 290 Call WRITE-CACHE with the HTTP input port and the cache output port to write
 291 the data to cache.  Call CACHE-MISS with URI just before fetching data from
 292 URI.
 293
 294 TIMEOUT specifies the timeout in seconds for connection establishment.
 295
 296 Write information about redirects to LOG-PORT."
 297   (let ((file (cache-file-for-uri uri)))
 298     (define (update-cache cache-port)
 299       (define cache-time
 300         (and cache-port
 301              (stat:mtime (stat cache-port))))
 302
 303       (define headers
 304         `((user-agent . "GNU Guile")
 305           ,@(if cache-time
 306                 `((if-modified-since
 307                    . ,(time-utc->date (make-time time-utc 0 cache-time))))
 308                 '())))
 309
 310       ;; Update the cache and return an input port.
 311       (guard (c ((http-get-error? c)
 312                  (if (= 304 (http-get-error-code c)) ;"Not Modified"
 313                      (begin
 314                        (utime file)               ;update FILE's mtime
 315                        cache-port)
 316                      (raise c))))
 317         (let ((port (http-fetch uri #:text? text?
 318                                 #:log-port log-port
 319                                 #:headers headers #:timeout timeout)))
 320           (cache-miss uri)
 321           (mkdir-p (dirname file))
 322           (when cache-port
 323             (close-port cache-port))
 324           (with-atomic-file-output file
 325             (cut write-cache port <>))
 326           (close-port port)
 327           (open-input-file file))))
 328
 329     (define (old? port)
 330       ;; Return true if PORT has passed TTL.
 331       (let* ((s   (stat port))
 332              (now (current-time time-utc)))
 333         (< (+ (stat:mtime s) ttl) (time-second now))))
 334
 335     (catch 'system-error
 336       (lambda ()
 337         (let ((port (open-input-file file)))
 338           (if (old? port)
 339               (update-cache port)
 340               port)))
 341       (lambda args
 342         (if (= ENOENT (system-error-errno args))
 343             (update-cache #f)
 344             (apply throw args))))))
 345
 346 ;;; http-client.scm ends here