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>
7 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
62 call-with-connection-error-handling
65 lookup-narinfos/diverse))
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.
73 (define %narinfo-negative-ttl
74 ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
77 (define %narinfo-transient-error-ttl
78 ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
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.
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")))
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)
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)))
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."
110 (current-time time-monotonic))
112 (define (cache-entry cache-uri narinfo)
113 `(narinfo (version 2)
114 (cache-uri ,cache-uri)
115 (date ,(time-second now))
117 (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
118 (value ,(and=> narinfo narinfo->string))))
120 (let ((file (narinfo-cache-file cache-url path)))
121 (mkdir-p (dirname file))
122 (with-atomic-file-output file
124 (write (cache-entry cache-url narinfo) out))))
128 (define %unreachable-hosts
129 ;; Set of names of unreachable hosts.
132 (define* (call-with-connection-error-handling uri proc)
133 "Call PROC, and catch if a connection fails, print a warning and return #f."
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)))
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
151 (system-error-errno `(system-error ,@args)))))
154 (apply throw args)))))
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)
160 (headers '((User-Agent . "GNU Guile"))))
161 (build-request (string->uri url) #:method 'GET #:headers headers)))
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."
168 (call-with-input-file file
169 (cut read-narinfo <> url)))
171 (if (= ENOENT (system-error-errno args))
173 (apply throw args)))))
175 (define* (fetch-narinfos url paths
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)
185 (define hash-part->path
186 (let ((mapping (fold (lambda (path result)
187 (vhash-cons (store-path-hash-part path) path
192 (match (vhash-assoc hash mapping)
194 ((_ . path) path)))))
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")))
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)
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))
214 (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
215 (cons narinfo result))
217 (let* ((path (uri-path (request-uri request)))
219 (string-drop-right path 8)))) ;drop ".narinfo"
221 (get-bytevector-n port len)
223 (cache-narinfo! url (hash-part->path hash-part) #f
224 (if (or (= 404 code) (= 202 code))
226 %narinfo-transient-error-ttl))
229 (define (do-fetch uri)
230 (case (and=> uri uri-scheme)
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))
237 (start-progress-reporter! progress-reporter)
238 (call-with-connection-error-handling
241 (http-multiple-get uri
242 handle-narinfo-response '()
244 #:open-connection open-connection
245 #:verify-certificate? #f))))))
246 (stop-progress-reporter! progress-reporter)
249 (let* ((base (string-append (uri-path uri) "/"))
250 (files (map (compose (cut string-append base <> ".narinfo")
251 store-path-hash-part)
253 (filter-map (cut narinfo-from-file <> url) files)))
255 (leave (G_ "~s: unsupported server URI scheme~%")
256 (if uri (uri-scheme uri) url)))))
258 (do-fetch (string->uri url)))
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
266 (current-time time-monotonic))
269 (narinfo-cache-file cache-url path))
273 (call-with-input-file cache-file
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)
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)
289 (values #t (string->narinfo value cache-uri))))
290 (('narinfo ('version v) _ ...)
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)))
307 (values (cons value cached) missing)
308 (values cached missing))
309 (values cached (cons path missing)))))
313 (values (if (null? missing)
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 '()))))
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
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)
336 (match (vhash-fold* cons '() path result)
340 (let ((authorized (find authorized? (reverse several))))
342 (find (cut equivalent-narinfo? <> authorized)
345 (let loop ((caches caches)
347 (result vlist-null) ;path->narinfo vhash
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))
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
365 (fold vhash-cons result
366 (map narinfo-path narinfos) narinfos)
367 (append definite hits))))
369 (filter-map (select-hit result) hits)))))))
371 ;;; substitutes.scm ends here