guix/substitutes.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
   5 ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
   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 substitutes)
  23   #:use-module (guix narinfo)
  24   #:use-module (guix store)
  25   #:use-module (guix utils)
  26   #:use-module (guix combinators)
  27   #:use-module (guix config)
  28   #:use-module (guix records)
  29   #:use-module (guix diagnostics)
  30   #:use-module (guix i18n)
  31   #:use-module (gcrypt hash)
  32   #:use-module (guix base32)
  33   #:use-module (guix base64)
  34   #:use-module (guix cache)
  35   #:use-module (gcrypt pk-crypto)
  36   #:use-module (guix pki)
  37   #:use-module ((guix build utils) #:select (mkdir-p dump-port))
  38   #:use-module ((guix build download)
  39                 #:select ((open-connection-for-uri
  40                            . guix:open-connection-for-uri)
  41                           resolve-uri-reference))
  42   #:use-module (guix progress)
  43   #:use-module (ice-9 rdelim)
  44   #:use-module (ice-9 regex)
  45   #:use-module (ice-9 match)
  46   #:use-module (ice-9 format)
  47   #:use-module (ice-9 ftw)
  48   #:use-module (ice-9 binary-ports)
  49   #:use-module (ice-9 vlist)
  50   #:use-module (rnrs bytevectors)
  51   #:use-module (srfi srfi-1)
  52   #:use-module (srfi srfi-11)
  53   #:use-module (srfi srfi-19)
  54   #:use-module (srfi srfi-26)
  55   #:use-module (srfi srfi-34)
  56   #:use-module (srfi srfi-35)
  57   #:use-module (web uri)
  58   #:use-module (web request)
  59   #:use-module (web response)
  60   #:use-module (guix http-client)
  61   #:export (%narinfo-cache-directory
  62
  63             call-with-connection-error-handling
  64
  65             lookup-narinfos
  66             lookup-narinfos/diverse))
  67
  68 (define %narinfo-ttl
  69   ;; Number of seconds during which cached narinfo lookups are considered
  70   ;; valid for substitute servers that do not advertise a TTL via the
  71   ;; 'Cache-Control' response header.
  72   (* 36 3600))
  73
  74 (define %narinfo-negative-ttl
  75   ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
  76   (* 10 60))
  77
  78 (define %narinfo-transient-error-ttl
  79   ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
  80   (* 5 60))
  81
  82 (define %narinfo-cache-directory
  83   ;; A local cache of narinfos, to avoid going to the network.  Most of the
  84   ;; time, 'guix substitute' is called by guix-daemon as root and stores its
  85   ;; cached data in /var/guix/….  However, when invoked from 'guix challenge'
  86   ;; as a user, it stores its cache in ~/.cache.
  87   (if (zero? (getuid))
  88       (or (and=> (getenv "XDG_CACHE_HOME")
  89                  (cut string-append <> "/guix/substitute"))
  90           (string-append %state-directory "/substitute/cache"))
  91       (string-append (cache-directory #:ensure? #f) "/substitute")))
  92
  93 (define (narinfo-cache-file cache-url path)
  94   "Return the name of the local file that contains an entry for PATH.  The
  95 entry is stored in a sub-directory specific to CACHE-URL."
  96   ;; The daemon does not sanitize its input, so PATH could be something like
  97   ;; "/gnu/store/foo".  Gracefully handle that.
  98   (match (store-path-hash-part path)
  99     (#f
 100      (leave (G_ "'~a' does not name a store item~%") path))
 101     ((? string? hash-part)
 102      (string-append %narinfo-cache-directory "/"
 103                     (bytevector->base32-string (sha256 (string->utf8 cache-url)))
 104                     "/" hash-part))))
 105
 106 (define (cache-narinfo! cache-url path narinfo ttl)
 107   "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
 108 given TTL (a number of seconds or #f).  NARINFO may be #f, in which case it
 109 indicates that PATH is unavailable at CACHE-URL."
 110   (define now
 111     (current-time time-monotonic))
 112
 113   (define (cache-entry cache-uri narinfo)
 114     `(narinfo (version 2)
 115               (cache-uri ,cache-uri)
 116               (date ,(time-second now))
 117               (ttl ,(or ttl
 118                         (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
 119               (value ,(and=> narinfo narinfo->string))))
 120
 121   (let ((file (narinfo-cache-file cache-url path)))
 122     (mkdir-p (dirname file))
 123     (with-atomic-file-output file
 124       (lambda (out)
 125         (write (cache-entry cache-url narinfo) out))))
 126
 127   narinfo)
 128
 129 (define %unreachable-hosts
 130   ;; Set of names of unreachable hosts.
 131   (make-hash-table))
 132
 133 (define* (call-with-connection-error-handling uri proc)
 134   "Call PROC, and catch if a connection fails, print a warning and return #f."
 135   (define host
 136     (uri-host uri))
 137
 138   (catch #t
 139     proc
 140     (match-lambda*
 141       (('getaddrinfo-error error)
 142        (unless (hash-ref %unreachable-hosts host)
 143          (hash-set! %unreachable-hosts host #t)   ;warn only once
 144          (warning (G_ "~a: host not found: ~a~%")
 145                   host (gai-strerror error)))
 146        #f)
 147       (('system-error . args)
 148        (unless (hash-ref %unreachable-hosts host)
 149          (hash-set! %unreachable-hosts host #t)
 150          (warning (G_ "~a: connection failed: ~a~%") host
 151                   (strerror
 152                    (system-error-errno `(system-error ,@args)))))
 153        #f)
 154       (args
 155        (apply throw args)))))
 156
 157 (define (narinfo-request cache-url path)
 158   "Return an HTTP request for the narinfo of PATH at CACHE-URL."
 159   ;; Ensure BASE has a trailing slash so that REF is correct regardless of
 160   ;; whether the user-provided CACHE-URL has a trailing slash.
 161   (let* ((base (string->uri (if (string-suffix? "/" cache-url)
 162                                 cache-url
 163                                 (string-append cache-url "/"))))
 164          (ref (build-relative-ref
 165                #:path (string-append (store-path-hash-part path) ".narinfo")))
 166          (url (resolve-uri-reference ref base))
 167          (headers '((User-Agent . "GNU Guile"))))
 168     (build-request url #:method 'GET #:headers headers)))
 169
 170 (define (narinfo-from-file file url)
 171   "Attempt to read a narinfo from FILE, using URL as the cache URL.  Return #f
 172 if file doesn't exist, and the narinfo otherwise."
 173   (catch 'system-error
 174     (lambda ()
 175       (call-with-input-file file
 176         (cut read-narinfo <> url)))
 177     (lambda args
 178       (if (= ENOENT (system-error-errno args))
 179           #f
 180           (apply throw args)))))
 181
 182 (define* (fetch-narinfos url paths
 183                          #:key
 184                          (open-connection guix:open-connection-for-uri)
 185                          (make-progress-reporter
 186                           (const progress-reporter/silent)))
 187   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
 188   (define progress-reporter
 189     (make-progress-reporter (length paths)
 190                             #:url url))
 191
 192   (define hash-part->path
 193     (let ((mapping (fold (lambda (path result)
 194                            (vhash-cons (store-path-hash-part path) path
 195                                        result))
 196                          vlist-null
 197                          paths)))
 198       (lambda (hash)
 199         (match (vhash-assoc hash mapping)
 200           (#f #f)
 201           ((_ . path) path)))))
 202
 203   (define (read-to-eof port)
 204     "Read from PORT until EOF is reached.  The data are discarded."
 205     (dump-port port (%make-void-port "w")))
 206
 207   (define (handle-narinfo-response request response port result)
 208     (let* ((code   (response-code response))
 209            (len    (response-content-length response))
 210            (cache  (response-cache-control response))
 211            (ttl    (and cache (assoc-ref cache 'max-age))))
 212       (progress-reporter-report! progress-reporter)
 213
 214       ;; Make sure to read no more than LEN bytes since subsequent bytes may
 215       ;; belong to the next response.
 216       (if (= code 200)                            ; hit
 217           (let ((narinfo (read-narinfo port url #:size len)))
 218             (if (string=? (dirname (narinfo-path narinfo))
 219                           (%store-prefix))
 220                 (begin
 221                   (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
 222                   (cons narinfo result))
 223                 result))
 224           (let* ((path      (uri-path (request-uri request)))
 225                  (hash-part (basename
 226                              (string-drop-right path 8)))) ;drop ".narinfo"
 227             (if len
 228                 (get-bytevector-n port len)
 229                 (read-to-eof port))
 230             (cache-narinfo! url (hash-part->path hash-part) #f
 231                             (if (or (= 404 code) (= 202 code))
 232                                 ttl
 233                                 %narinfo-transient-error-ttl))
 234             result))))
 235
 236   (define (do-fetch uri)
 237     (case (and=> uri uri-scheme)
 238       ((http https)
 239        ;; Note: Do not check HTTPS server certificates to avoid depending
 240        ;; on the X.509 PKI.  We can do it because we authenticate
 241        ;; narinfos, which provides a much stronger guarantee.
 242        (let* ((requests (map (cut narinfo-request url <>) paths))
 243               (result   (begin
 244                           (start-progress-reporter! progress-reporter)
 245                           (call-with-connection-error-handling
 246                            uri
 247                            (lambda ()
 248                              (http-multiple-get uri
 249                                                 handle-narinfo-response '()
 250                                                 requests
 251                                                 #:open-connection open-connection
 252                                                 #:verify-certificate? #f))))))
 253          (stop-progress-reporter! progress-reporter)
 254          result))
 255       ((file #f)
 256        (let* ((base  (string-append (uri-path uri) "/"))
 257               (files (map (compose (cut string-append base <> ".narinfo")
 258                                    store-path-hash-part)
 259                           paths)))
 260          (filter-map (cut narinfo-from-file <> url) files)))
 261       (else
 262        (leave (G_ "~s: unsupported server URI scheme~%")
 263               (if uri (uri-scheme uri) url)))))
 264
 265   (do-fetch (string->uri url)))
 266
 267 (define (cached-narinfo cache-url path)
 268   "Check locally if we have valid info about PATH coming from CACHE-URL.
 269 Return two values: a Boolean indicating whether we have valid cached info, and
 270 that info, which may be either #f (when PATH is unavailable) or the narinfo
 271 for PATH."
 272   (define now
 273     (current-time time-monotonic))
 274
 275   (define cache-file
 276     (narinfo-cache-file cache-url path))
 277
 278   (catch 'system-error
 279     (lambda ()
 280       (call-with-input-file cache-file
 281         (lambda (p)
 282           (match (read p)
 283             (('narinfo ('version 2)
 284                        ('cache-uri cache-uri)
 285                        ('date date) ('ttl ttl) ('value #f))
 286              ;; A cached negative lookup.
 287              (if (obsolete? date now ttl)
 288                  (values #f #f)
 289                  (values #t #f)))
 290             (('narinfo ('version 2)
 291                        ('cache-uri cache-uri)
 292                        ('date date) ('ttl ttl) ('value value))
 293              ;; A cached positive lookup
 294              (if (obsolete? date now ttl)
 295                  (values #f #f)
 296                  (values #t (string->narinfo value cache-uri))))
 297             (('narinfo ('version v) _ ...)
 298              (values #f #f))))))
 299     (lambda _
 300       (values #f #f))))
 301
 302 (define* (lookup-narinfos cache paths
 303                           #:key (open-connection guix:open-connection-for-uri)
 304                           (make-progress-reporter
 305                            (const progress-reporter/silent)))
 306   "Return the narinfos for PATHS, invoking the server at CACHE when no
 307 information is available locally."
 308   (let-values (((cached missing)
 309                 (fold2 (lambda (path cached missing)
 310                          (let-values (((valid? value)
 311                                        (cached-narinfo cache path)))
 312                            (if valid?
 313                                (if value
 314                                    (values (cons value cached) missing)
 315                                    (values cached missing))
 316                                (values cached (cons path missing)))))
 317                        '()
 318                        '()
 319                        paths)))
 320     (values (if (null? missing)
 321                 cached
 322                 (let ((missing (fetch-narinfos cache missing
 323                                                #:open-connection open-connection
 324                                                #:make-progress-reporter
 325                                                make-progress-reporter)))
 326                   (append cached (or missing '()))))
 327             (length missing))))
 328
 329 (define* (lookup-narinfos/diverse caches paths authorized?
 330                                   #:key (open-connection
 331                                          guix:open-connection-for-uri)
 332                                   (make-progress-reporter
 333                                    (const progress-reporter/silent)))
 334   "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
 335 That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
 336 cache, and so on.
 337
 338 Return a list of narinfos for PATHS or a subset thereof.  The returned
 339 narinfos are either AUTHORIZED?, or they claim a hash that matches an
 340 AUTHORIZED? narinfo."
 341   (define (select-hit result)
 342     (lambda (path)
 343       (match (vhash-fold* cons '() path result)
 344         ((one)
 345          one)
 346         ((several ..1)
 347          (let ((authorized (find authorized? (reverse several))))
 348            (and authorized
 349                 (find (cut equivalent-narinfo? <> authorized)
 350                       several)))))))
 351
 352   (let loop ((caches caches)
 353              (paths  paths)
 354              (result vlist-null)                  ;path->narinfo vhash
 355              (hits   '()))                        ;paths
 356     (match paths
 357       (()                                         ;we're done
 358        ;; Now iterate on all the HITS, and return exactly one match for each
 359        ;; hit: the first narinfo that is authorized, or that has the same hash
 360        ;; as an authorized narinfo, in the order of CACHES.
 361        (filter-map (select-hit result) hits))
 362       (_
 363        (match caches
 364          ((cache rest ...)
 365           (let* ((narinfos (lookup-narinfos cache paths
 366                                             #:open-connection open-connection
 367                                             #:make-progress-reporter
 368                                             make-progress-reporter))
 369                  (definite (map narinfo-path (filter authorized? narinfos)))
 370                  (missing  (lset-difference string=? paths definite))) ;XXX: perf
 371             (loop rest missing
 372                   (fold vhash-cons result
 373                         (map narinfo-path narinfos) narinfos)
 374                   (append definite hits))))
 375          (()                                      ;that's it
 376           (filter-map (select-hit result) hits)))))))
 377
 378 ;;; substitutes.scm ends here