guix/substitutes.scm

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