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 (open-connection guix:open-connection-for-uri))
 177   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
 178   (define update-progress!
 179     (let ((done 0)
 180           (total (length paths)))
 181       (lambda ()
 182         (display "\r\x1b[K" (current-error-port)) ;erase current line
 183         (force-output (current-error-port))
 184         (format (current-error-port)
 185                 (G_ "updating substitutes from '~a'... ~5,1f%")
 186                 url (* 100. (/ done total)))
 187         (set! done (+ 1 done)))))
 188
 189   (define hash-part->path
 190     (let ((mapping (fold (lambda (path result)
 191                            (vhash-cons (store-path-hash-part path) path
 192                                        result))
 193                          vlist-null
 194                          paths)))
 195       (lambda (hash)
 196         (match (vhash-assoc hash mapping)
 197           (#f #f)
 198           ((_ . path) path)))))
 199
 200   (define (read-to-eof port)
 201     "Read from PORT until EOF is reached.  The data are discarded."
 202     (dump-port port (%make-void-port "w")))
 203
 204   (define (handle-narinfo-response request response port result)
 205     (let* ((code   (response-code response))
 206            (len    (response-content-length response))
 207            (cache  (response-cache-control response))
 208            (ttl    (and cache (assoc-ref cache 'max-age))))
 209       (update-progress!)
 210
 211       ;; Make sure to read no more than LEN bytes since subsequent bytes may
 212       ;; belong to the next response.
 213       (if (= code 200)                            ; hit
 214           (let ((narinfo (read-narinfo port url #:size len)))
 215             (if (string=? (dirname (narinfo-path narinfo))
 216                           (%store-prefix))
 217                 (begin
 218                   (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
 219                   (cons narinfo result))
 220                 result))
 221           (let* ((path      (uri-path (request-uri request)))
 222                  (hash-part (basename
 223                              (string-drop-right path 8)))) ;drop ".narinfo"
 224             (if len
 225                 (get-bytevector-n port len)
 226                 (read-to-eof port))
 227             (cache-narinfo! url (hash-part->path hash-part) #f
 228                             (if (or (= 404 code) (= 202 code))
 229                                 ttl
 230                                 %narinfo-transient-error-ttl))
 231             result))))
 232
 233   (define (do-fetch uri)
 234     (case (and=> uri uri-scheme)
 235       ((http https)
 236        ;; Note: Do not check HTTPS server certificates to avoid depending
 237        ;; on the X.509 PKI.  We can do it because we authenticate
 238        ;; narinfos, which provides a much stronger guarantee.
 239        (let* ((requests (map (cut narinfo-request url <>) paths))
 240               (result   (begin
 241                           (update-progress!)
 242                           (call-with-connection-error-handling
 243                            uri
 244                            (lambda ()
 245                              (http-multiple-get uri
 246                                                 handle-narinfo-response '()
 247                                                 requests
 248                                                 #:open-connection open-connection
 249                                                 #:verify-certificate? #f))))))
 250          (newline (current-error-port))
 251          result))
 252       ((file #f)
 253        (let* ((base  (string-append (uri-path uri) "/"))
 254               (files (map (compose (cut string-append base <> ".narinfo")
 255                                    store-path-hash-part)
 256                           paths)))
 257          (filter-map (cut narinfo-from-file <> url) files)))
 258       (else
 259        (leave (G_ "~s: unsupported server URI scheme~%")
 260               (if uri (uri-scheme uri) url)))))
 261
 262   (do-fetch (string->uri url)))
 263
 264 (define (cached-narinfo cache-url path)
 265   "Check locally if we have valid info about PATH coming from CACHE-URL.
 266 Return two values: a Boolean indicating whether we have valid cached info, and
 267 that info, which may be either #f (when PATH is unavailable) or the narinfo
 268 for PATH."
 269   (define now
 270     (current-time time-monotonic))
 271
 272   (define cache-file
 273     (narinfo-cache-file cache-url path))
 274
 275   (catch 'system-error
 276     (lambda ()
 277       (call-with-input-file cache-file
 278         (lambda (p)
 279           (match (read p)
 280             (('narinfo ('version 2)
 281                        ('cache-uri cache-uri)
 282                        ('date date) ('ttl ttl) ('value #f))
 283              ;; A cached negative lookup.
 284              (if (obsolete? date now ttl)
 285                  (values #f #f)
 286                  (values #t #f)))
 287             (('narinfo ('version 2)
 288                        ('cache-uri cache-uri)
 289                        ('date date) ('ttl ttl) ('value value))
 290              ;; A cached positive lookup
 291              (if (obsolete? date now ttl)
 292                  (values #f #f)
 293                  (values #t (string->narinfo value cache-uri))))
 294             (('narinfo ('version v) _ ...)
 295              (values #f #f))))))
 296     (lambda _
 297       (values #f #f))))
 298
 299 (define* (lookup-narinfos cache paths
 300                           #:key (open-connection guix:open-connection-for-uri))
 301   "Return the narinfos for PATHS, invoking the server at CACHE when no
 302 information is available locally."
 303   (let-values (((cached missing)
 304                 (fold2 (lambda (path cached missing)
 305                          (let-values (((valid? value)
 306                                        (cached-narinfo cache path)))
 307                            (if valid?
 308                                (if value
 309                                    (values (cons value cached) missing)
 310                                    (values cached missing))
 311                                (values cached (cons path missing)))))
 312                        '()
 313                        '()
 314                        paths)))
 315     (if (null? missing)
 316         cached
 317         (let ((missing (fetch-narinfos cache missing
 318                                        #:open-connection open-connection)))
 319           (append cached (or missing '()))))))
 320
 321 (define* (lookup-narinfos/diverse caches paths authorized?
 322                                   #:key (open-connection
 323                                          guix:open-connection-for-uri))
 324   "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
 325 That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
 326 cache, and so on.
 327
 328 Return a list of narinfos for PATHS or a subset thereof.  The returned
 329 narinfos are either AUTHORIZED?, or they claim a hash that matches an
 330 AUTHORIZED? narinfo."
 331   (define (select-hit result)
 332     (lambda (path)
 333       (match (vhash-fold* cons '() path result)
 334         ((one)
 335          one)
 336         ((several ..1)
 337          (let ((authorized (find authorized? (reverse several))))
 338            (and authorized
 339                 (find (cut equivalent-narinfo? <> authorized)
 340                       several)))))))
 341
 342   (let loop ((caches caches)
 343              (paths  paths)
 344              (result vlist-null)                  ;path->narinfo vhash
 345              (hits   '()))                        ;paths
 346     (match paths
 347       (()                                         ;we're done
 348        ;; Now iterate on all the HITS, and return exactly one match for each
 349        ;; hit: the first narinfo that is authorized, or that has the same hash
 350        ;; as an authorized narinfo, in the order of CACHES.
 351        (filter-map (select-hit result) hits))
 352       (_
 353        (match caches
 354          ((cache rest ...)
 355           (let* ((narinfos (lookup-narinfos cache paths
 356                                             #:open-connection open-connection))
 357                  (definite (map narinfo-path (filter authorized? narinfos)))
 358                  (missing  (lset-difference string=? paths definite))) ;XXX: perf
 359             (loop rest missing
 360                   (fold vhash-cons result
 361                         (map narinfo-path narinfos) narinfos)
 362                   (append definite hits))))
 363          (()                                      ;that's it
 364           (filter-map (select-hit result) hits)))))))
 365
 366 ;;; substitutes.scm ends here