Commit | Line | Data |
---|---|---|
112692c0 CB |
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 | |
fd5b7750 CB |
176 | #:key |
177 | (open-connection guix:open-connection-for-uri) | |
178 | (make-progress-reporter | |
179 | (const progress-reporter/silent))) | |
112692c0 | 180 | "Retrieve all the narinfos for PATHS from the cache at URL and return them." |
fd5b7750 CB |
181 | (define progress-reporter |
182 | (make-progress-reporter (length paths) | |
183 | #:url url)) | |
112692c0 CB |
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)))) | |
fd5b7750 | 205 | (progress-reporter-report! progress-reporter) |
112692c0 CB |
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 | |
fd5b7750 | 237 | (start-progress-reporter! progress-reporter) |
112692c0 CB |
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)))))) | |
fd5b7750 | 246 | (stop-progress-reporter! progress-reporter) |
112692c0 CB |
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 | |
fd5b7750 CB |
296 | #:key (open-connection guix:open-connection-for-uri) |
297 | (make-progress-reporter | |
298 | (const progress-reporter/silent))) | |
112692c0 CB |
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))) | |
c5ab78f9 CB |
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)))) | |
112692c0 CB |
321 | |
322 | (define* (lookup-narinfos/diverse caches paths authorized? | |
323 | #:key (open-connection | |
fd5b7750 CB |
324 | guix:open-connection-for-uri) |
325 | (make-progress-reporter | |
326 | (const progress-reporter/silent))) | |
112692c0 CB |
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 | |
fd5b7750 CB |
359 | #:open-connection open-connection |
360 | #:make-progress-reporter | |
361 | make-progress-reporter)) | |
112692c0 CB |
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 |