Commit | Line | Data |
---|---|---|
f65cf81a | 1 | ;;; GNU Guix --- Functional package management for GNU |
f4cde9ac | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
e9c6c584 | 3 | ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
7ede577a | 4 | ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> |
f65cf81a LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
2c74fde0 | 21 | (define-module (guix scripts substitute) |
f65cf81a | 22 | #:use-module (guix ui) |
3794ce93 | 23 | #:use-module (guix scripts) |
f4cde9ac | 24 | #:use-module (guix store) |
f65cf81a | 25 | #:use-module (guix utils) |
958dd3ce | 26 | #:use-module (guix combinators) |
fe0cff14 | 27 | #:use-module (guix config) |
c0cd1b3e | 28 | #:use-module (guix records) |
2535635f | 29 | #:use-module ((guix serialization) #:select (restore-file)) |
35a32fef | 30 | #:autoload (guix scripts discover) (read-substitute-urls) |
ca719424 | 31 | #:use-module (gcrypt hash) |
895d1eda | 32 | #:use-module (guix base32) |
e9c6c584 | 33 | #:use-module (guix base64) |
2ea2aac6 | 34 | #:use-module (guix cache) |
ca719424 | 35 | #:use-module (gcrypt pk-crypto) |
e9c6c584 | 36 | #:use-module (guix pki) |
d3a65203 | 37 | #:use-module ((guix build utils) #:select (mkdir-p dump-port)) |
a85060ef | 38 | #:use-module ((guix build download) |
8c348825 | 39 | #:select (uri-abbreviation nar-uri-abbreviation |
4fd06a4d LC |
40 | (open-connection-for-uri |
41 | . guix:open-connection-for-uri) | |
a8be7b9a | 42 | store-path-abbreviation byte-count->string)) |
8c348825 | 43 | #:use-module (guix progress) |
8902d0f2 LC |
44 | #:use-module ((guix build syscalls) |
45 | #:select (set-thread-name)) | |
f65cf81a LC |
46 | #:use-module (ice-9 rdelim) |
47 | #:use-module (ice-9 regex) | |
48 | #:use-module (ice-9 match) | |
fe0cff14 | 49 | #:use-module (ice-9 format) |
4c7cacf1 | 50 | #:use-module (ice-9 ftw) |
a85060ef | 51 | #:use-module (ice-9 binary-ports) |
3d3e93b3 | 52 | #:use-module (ice-9 vlist) |
e9c6c584 | 53 | #:use-module (rnrs bytevectors) |
f65cf81a LC |
54 | #:use-module (srfi srfi-1) |
55 | #:use-module (srfi srfi-9) | |
56 | #:use-module (srfi srfi-11) | |
eba783b7 | 57 | #:use-module (srfi srfi-19) |
f65cf81a | 58 | #:use-module (srfi srfi-26) |
706e9e57 | 59 | #:use-module (srfi srfi-34) |
e9c6c584 | 60 | #:use-module (srfi srfi-35) |
f65cf81a | 61 | #:use-module (web uri) |
9b7bd1b1 | 62 | #:use-module (web http) |
d3a65203 LC |
63 | #:use-module (web request) |
64 | #:use-module (web response) | |
3b8258c5 | 65 | #:use-module (guix http-client) |
e9c6c584 | 66 | #:export (narinfo-signature->canonical-sexp |
ea0c6e05 LC |
67 | |
68 | narinfo? | |
69 | narinfo-path | |
b90ae065 | 70 | narinfo-uris |
ea0c6e05 | 71 | narinfo-uri-base |
b90ae065 LC |
72 | narinfo-compressions |
73 | narinfo-file-hashes | |
74 | narinfo-file-sizes | |
ea0c6e05 LC |
75 | narinfo-hash |
76 | narinfo-size | |
77 | narinfo-references | |
78 | narinfo-deriver | |
79 | narinfo-system | |
80 | narinfo-signature | |
81 | ||
82 | narinfo-hash->sha256 | |
4736d06f | 83 | narinfo-best-uri |
ea0c6e05 LC |
84 | |
85 | lookup-narinfos | |
55b2fc18 | 86 | lookup-narinfos/diverse |
e9c6c584 NK |
87 | read-narinfo |
88 | write-narinfo | |
218f6ecc | 89 | |
434138e2 | 90 | %allow-unauthenticated-substitutes? |
711df9ef | 91 | %error-to-file-descriptor-4? |
434138e2 | 92 | |
218f6ecc | 93 | substitute-urls |
2c74fde0 | 94 | guix-substitute)) |
f65cf81a LC |
95 | |
96 | ;;; Comment: | |
97 | ;;; | |
98 | ;;; This is the "binary substituter". It is invoked by the daemon do check | |
99 | ;;; for the existence of available "substitutes" (pre-built binaries), and to | |
100 | ;;; actually use them as a substitute to building things locally. | |
101 | ;;; | |
102 | ;;; If possible, substitute a binary for the requested store path, using a Nix | |
103 | ;;; "binary cache". This program implements the Nix "substituter" protocol. | |
104 | ;;; | |
105 | ;;; Code: | |
106 | ||
eba783b7 | 107 | (define %narinfo-cache-directory |
f10dcbf1 LC |
108 | ;; A local cache of narinfos, to avoid going to the network. Most of the |
109 | ;; time, 'guix substitute' is called by guix-daemon as root and stores its | |
110 | ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' | |
111 | ;; as a user, it stores its cache in ~/.cache. | |
112 | (if (zero? (getuid)) | |
113 | (or (and=> (getenv "XDG_CACHE_HOME") | |
114 | (cut string-append <> "/guix/substitute")) | |
115 | (string-append %state-directory "/substitute/cache")) | |
f0e492f0 | 116 | (string-append (cache-directory #:ensure? #f) "/substitute"))) |
eba783b7 | 117 | |
434138e2 LC |
118 | (define (warn-about-missing-authentication) |
119 | (warning (G_ "authentication and authorization of substitutes \ | |
120 | disabled!~%")) | |
121 | #t) | |
122 | ||
e9c6c584 NK |
123 | (define %allow-unauthenticated-substitutes? |
124 | ;; Whether to allow unchecked substitutes. This is useful for testing | |
125 | ;; purposes, and should be avoided otherwise. | |
434138e2 LC |
126 | (make-parameter |
127 | (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") | |
79c6614f | 128 | (cut string-ci=? <> "yes")))) |
e9c6c584 | 129 | |
eba783b7 LC |
130 | (define %narinfo-ttl |
131 | ;; Number of seconds during which cached narinfo lookups are considered | |
23d60ba6 LC |
132 | ;; valid for substitute servers that do not advertise a TTL via the |
133 | ;; 'Cache-Control' response header. | |
5e6039a4 | 134 | (* 36 3600)) |
eba783b7 LC |
135 | |
136 | (define %narinfo-negative-ttl | |
958fb14c | 137 | ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). |
099d709c | 138 | (* 1 3600)) |
eba783b7 | 139 | |
958fb14c LC |
140 | (define %narinfo-transient-error-ttl |
141 | ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). | |
142 | (* 10 60)) | |
143 | ||
4c7cacf1 LC |
144 | (define %narinfo-expired-cache-entry-removal-delay |
145 | ;; How often we want to remove files corresponding to expired cache entries. | |
146 | (* 7 24 3600)) | |
147 | ||
ce689ccf LC |
148 | (define fields->alist |
149 | ;; The narinfo format is really just like recutils. | |
150 | recutils->alist) | |
f65cf81a | 151 | |
2207f731 LC |
152 | (define %fetch-timeout |
153 | ;; Number of seconds after which networking is considered "slow". | |
8b79e2e6 | 154 | 5) |
2207f731 | 155 | |
bb7dcaea LC |
156 | (define %random-state |
157 | (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) | |
158 | ||
2207f731 LC |
159 | (define-syntax-rule (with-timeout duration handler body ...) |
160 | "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY | |
161 | again." | |
162 | (begin | |
163 | (sigaction SIGALRM | |
164 | (lambda (signum) | |
165 | (sigaction SIGALRM SIG_DFL) | |
166 | handler)) | |
167 | (alarm duration) | |
168 | (call-with-values | |
169 | (lambda () | |
170 | (let try () | |
171 | (catch 'system-error | |
172 | (lambda () | |
173 | body ...) | |
174 | (lambda args | |
c509bf8c LC |
175 | ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR |
176 | ;; because of the bug at | |
bb7dcaea LC |
177 | ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>. |
178 | ;; When that happens, try again. Note: SA_RESTART cannot be | |
179 | ;; used because of <http://bugs.gnu.org/14640>. | |
2207f731 | 180 | (if (= EINTR (system-error-errno args)) |
bb7dcaea LC |
181 | (begin |
182 | ;; Wait a little to avoid bursts. | |
183 | (usleep (random 3000000 %random-state)) | |
184 | (try)) | |
2207f731 LC |
185 | (apply throw args)))))) |
186 | (lambda result | |
187 | (alarm 0) | |
188 | (sigaction SIGALRM SIG_DFL) | |
189 | (apply values result))))) | |
190 | ||
5ff52145 LC |
191 | (define* (fetch uri #:key (buffered? #t) (timeout? #t) |
192 | (keep-alive? #f) (port #f)) | |
fe0cff14 | 193 | "Return a binary input port to URI and the number of bytes it's expected to |
5ff52145 LC |
194 | provide. |
195 | ||
196 | When PORT is true, use it as the underlying I/O port for HTTP transfers; when | |
197 | PORT is false, open a new connection for URI. When KEEP-ALIVE? is true, the | |
198 | connection (typically PORT) is kept open once data has been fetched from URI." | |
f65cf81a LC |
199 | (case (uri-scheme uri) |
200 | ((file) | |
b6952cad LC |
201 | (let ((port (open-file (uri-path uri) |
202 | (if buffered? "rb" "r0b")))) | |
fe0cff14 | 203 | (values port (stat:size (stat port))))) |
9b7bd1b1 | 204 | ((http https) |
706e9e57 | 205 | (guard (c ((http-get-error? c) |
69daee23 | 206 | (leave (G_ "download from '~a' failed: ~a, ~s~%") |
cc27dbcf LC |
207 | (uri->string (http-get-error-uri c)) |
208 | (http-get-error-code c) | |
209 | (http-get-error-reason c)))) | |
706e9e57 LC |
210 | ;; Test this with: |
211 | ;; sudo tc qdisc add dev eth0 root netem delay 1500ms | |
212 | ;; and then cancel with: | |
213 | ;; sudo tc qdisc del dev eth0 root | |
5ff52145 | 214 | (let ((port port)) |
09d809db | 215 | (with-timeout (if timeout? |
706e9e57 LC |
216 | %fetch-timeout |
217 | 0) | |
218 | (begin | |
69daee23 | 219 | (warning (G_ "while fetching ~a: server is somewhat slow~%") |
706e9e57 | 220 | (uri->string uri)) |
1d84d7bf | 221 | (warning (G_ "try `--no-substitutes' if the problem persists~%"))) |
706e9e57 LC |
222 | (begin |
223 | (when (or (not port) (port-closed? port)) | |
4fd06a4d | 224 | (set! port (guix:open-connection-for-uri |
5ff52145 LC |
225 | uri #:verify-certificate? #f))) |
226 | (unless (or buffered? (not (file-port? port))) | |
227 | (setvbuf port 'none)) | |
166ba5b1 | 228 | (http-fetch uri #:text? #f #:port port |
5ff52145 | 229 | #:keep-alive? keep-alive? |
166ba5b1 | 230 | #:verify-certificate? #f)))))) |
204d34ff | 231 | (else |
69daee23 | 232 | (leave (G_ "unsupported substitute URI scheme: ~a~%") |
204d34ff | 233 | (uri->string uri))))) |
f65cf81a | 234 | |
074efd63 | 235 | \f |
f65cf81a | 236 | (define-record-type <narinfo> |
b90ae065 LC |
237 | (%make-narinfo path uri-base uris compressions file-sizes file-hashes |
238 | nar-hash nar-size references deriver system | |
239 | signature contents) | |
f65cf81a LC |
240 | narinfo? |
241 | (path narinfo-path) | |
b90ae065 LC |
242 | (uri-base narinfo-uri-base) ;URI of the cache it originates from |
243 | (uris narinfo-uris) ;list of strings | |
244 | (compressions narinfo-compressions) ;list of strings | |
245 | (file-sizes narinfo-file-sizes) ;list of (integers | #f) | |
246 | (file-hashes narinfo-file-hashes) | |
f65cf81a LC |
247 | (nar-hash narinfo-hash) |
248 | (nar-size narinfo-size) | |
249 | (references narinfo-references) | |
250 | (deriver narinfo-deriver) | |
e9c6c584 NK |
251 | (system narinfo-system) |
252 | (signature narinfo-signature) ; canonical sexp | |
253 | ;; The original contents of a narinfo file. This field is needed because we | |
254 | ;; want to preserve the exact textual representation for verification purposes. | |
255 | ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> | |
256 | ;; for more information. | |
257 | (contents narinfo-contents)) | |
258 | ||
ea0c6e05 LC |
259 | (define (narinfo-hash->sha256 hash) |
260 | "If the string HASH denotes a sha256 hash, return it as a bytevector. | |
261 | Otherwise return #f." | |
262 | (and (string-prefix? "sha256:" hash) | |
263 | (nix-base32-string->bytevector (string-drop hash 7)))) | |
264 | ||
e9c6c584 NK |
265 | (define (narinfo-signature->canonical-sexp str) |
266 | "Return the value of a narinfo's 'Signature' field as a canonical sexp." | |
267 | (match (string-split str #\;) | |
e465d9e1 | 268 | ((version host-name sig) |
e9c6c584 NK |
269 | (let ((maybe-number (string->number version))) |
270 | (cond ((not (number? maybe-number)) | |
69daee23 | 271 | (leave (G_ "signature version must be a number: ~s~%") |
e9c6c584 NK |
272 | version)) |
273 | ;; Currently, there are no other versions. | |
274 | ((not (= 1 maybe-number)) | |
69daee23 | 275 | (leave (G_ "unsupported signature version: ~a~%") |
e9c6c584 | 276 | maybe-number)) |
cdea30e0 LC |
277 | (else |
278 | (let ((signature (utf8->string (base64-decode sig)))) | |
279 | (catch 'gcry-error | |
280 | (lambda () | |
281 | (string->canonical-sexp signature)) | |
6ef3644e | 282 | (lambda (key proc err) |
69daee23 | 283 | (leave (G_ "signature is not a valid \ |
e4687a5e LC |
284 | s-expression: ~s~%") |
285 | signature)))))))) | |
e9c6c584 | 286 | (x |
69daee23 | 287 | (leave (G_ "invalid format of the signature field: ~a~%") x)))) |
f65cf81a | 288 | |
e9c6c584 NK |
289 | (define (narinfo-maker str cache-url) |
290 | "Return a narinfo constructor for narinfos originating from CACHE-URL. STR | |
291 | must contain the original contents of a narinfo file." | |
b90ae065 LC |
292 | (lambda (path urls compressions file-hashes file-sizes |
293 | nar-hash nar-size references deriver system | |
294 | signature) | |
fe0cff14 | 295 | "Return a new <narinfo> object." |
b90ae065 LC |
296 | (define len (length urls)) |
297 | (%make-narinfo path cache-url | |
fe0cff14 | 298 | ;; Handle the case where URL is a relative URL. |
b90ae065 LC |
299 | (map (lambda (url) |
300 | (or (string->uri url) | |
301 | (string->uri | |
302 | (string-append cache-url "/" url)))) | |
303 | urls) | |
304 | compressions | |
305 | (match file-sizes | |
306 | (() (make-list len #f)) | |
307 | ((lst ...) (map string->number lst))) | |
308 | (match file-hashes | |
309 | (() (make-list len #f)) | |
310 | ((lst ...) (map string->number lst))) | |
fe0cff14 LC |
311 | nar-hash |
312 | (and=> nar-size string->number) | |
313 | (string-tokenize references) | |
314 | (match deriver | |
315 | ((or #f "") #f) | |
316 | (_ deriver)) | |
e9c6c584 | 317 | system |
cdea30e0 LC |
318 | (false-if-exception |
319 | (and=> signature narinfo-signature->canonical-sexp)) | |
e9c6c584 | 320 | str))) |
f65cf81a | 321 | |
0561e9ae LC |
322 | (define* (read-narinfo port #:optional url |
323 | #:key size) | |
e9c6c584 | 324 | "Read a narinfo from PORT. If URL is true, it must be a string used to |
0561e9ae LC |
325 | build full URIs from relative URIs found while reading PORT. When SIZE is |
326 | true, read at most SIZE bytes from PORT; otherwise, read as much as possible. | |
cdea30e0 LC |
327 | |
328 | No authentication and authorization checks are performed here!" | |
0561e9ae LC |
329 | (let ((str (utf8->string (if size |
330 | (get-bytevector-n port size) | |
331 | (get-bytevector-all port))))) | |
cdea30e0 LC |
332 | (alist->record (call-with-input-string str fields->alist) |
333 | (narinfo-maker str url) | |
334 | '("StorePath" "URL" "Compression" | |
335 | "FileHash" "FileSize" "NarHash" "NarSize" | |
336 | "References" "Deriver" "System" | |
b90ae065 LC |
337 | "Signature") |
338 | '("URL" "Compression" "FileSize" "FileHash")))) | |
cdea30e0 | 339 | |
e4687a5e LC |
340 | (define (narinfo-sha256 narinfo) |
341 | "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a | |
342 | 'Signature' field." | |
60b04024 LC |
343 | (define %mandatory-fields |
344 | ;; List of fields that must be signed. If they are not signed, the | |
345 | ;; narinfo is considered unsigned. | |
346 | '("StorePath" "NarHash" "References")) | |
347 | ||
e4687a5e | 348 | (let ((contents (narinfo-contents narinfo))) |
8234fcf2 | 349 | (match (string-contains contents "Signature:") |
e4687a5e | 350 | (#f #f) |
8234fcf2 | 351 | (index |
60b04024 LC |
352 | (let* ((above-signature (string-take contents index)) |
353 | (signed-fields (match (call-with-input-string above-signature | |
354 | fields->alist) | |
355 | (((fields . values) ...) fields)))) | |
356 | (and (every (cut member <> signed-fields) %mandatory-fields) | |
357 | (sha256 (string->utf8 above-signature)))))))) | |
e4687a5e | 358 | |
a9468b42 LC |
359 | (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) |
360 | #:key verbose?) | |
cdea30e0 | 361 | "Return #t if NARINFO's signature is not valid." |
434138e2 | 362 | (or (%allow-unauthenticated-substitutes?) |
e4687a5e | 363 | (let ((hash (narinfo-sha256 narinfo)) |
a9468b42 | 364 | (signature (narinfo-signature narinfo)) |
b90ae065 | 365 | (uri (uri->string (first (narinfo-uris narinfo))))) |
e4687a5e LC |
366 | (and hash signature |
367 | (signature-case (signature hash acl) | |
368 | (valid-signature #t) | |
a9468b42 LC |
369 | (invalid-signature |
370 | (when verbose? | |
371 | (format (current-error-port) | |
372 | "invalid signature for substitute at '~a'~%" | |
373 | uri)) | |
374 | #f) | |
375 | (hash-mismatch | |
376 | (when verbose? | |
377 | (format (current-error-port) | |
378 | "hash mismatch for substitute at '~a'~%" | |
379 | uri)) | |
380 | #f) | |
381 | (unauthorized-key | |
382 | (when verbose? | |
383 | (format (current-error-port) | |
384 | "substitute at '~a' is signed by an \ | |
385 | unauthorized party~%" | |
386 | uri)) | |
387 | #f) | |
388 | (corrupt-signature | |
389 | (when verbose? | |
390 | (format (current-error-port) | |
391 | "corrupt signature for substitute at '~a'~%" | |
392 | uri)) | |
393 | #f)))))) | |
eba783b7 LC |
394 | |
395 | (define (write-narinfo narinfo port) | |
396 | "Write NARINFO to PORT." | |
e9c6c584 | 397 | (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) |
eba783b7 LC |
398 | |
399 | (define (narinfo->string narinfo) | |
400 | "Return the external representation of NARINFO." | |
401 | (call-with-output-string (cut write-narinfo narinfo <>))) | |
402 | ||
00230df1 | 403 | (define (string->narinfo str cache-uri) |
cdea30e0 LC |
404 | "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of |
405 | the cache STR originates form." | |
00230df1 | 406 | (call-with-input-string str (cut read-narinfo <> cache-uri))) |
eba783b7 | 407 | |
895d1eda LC |
408 | (define (narinfo-cache-file cache-url path) |
409 | "Return the name of the local file that contains an entry for PATH. The | |
410 | entry is stored in a sub-directory specific to CACHE-URL." | |
30d4bc04 LC |
411 | ;; The daemon does not sanitize its input, so PATH could be something like |
412 | ;; "/gnu/store/foo". Gracefully handle that. | |
413 | (match (store-path-hash-part path) | |
414 | (#f | |
69daee23 | 415 | (leave (G_ "'~a' does not name a store item~%") path)) |
30d4bc04 LC |
416 | ((? string? hash-part) |
417 | (string-append %narinfo-cache-directory "/" | |
418 | (bytevector->base32-string (sha256 (string->utf8 cache-url))) | |
419 | "/" hash-part)))) | |
895d1eda LC |
420 | |
421 | (define (cached-narinfo cache-url path) | |
422 | "Check locally if we have valid info about PATH coming from CACHE-URL. | |
423 | Return two values: a Boolean indicating whether we have valid cached info, and | |
424 | that info, which may be either #f (when PATH is unavailable) or the narinfo | |
425 | for PATH." | |
eba783b7 LC |
426 | (define now |
427 | (current-time time-monotonic)) | |
428 | ||
eba783b7 | 429 | (define cache-file |
895d1eda | 430 | (narinfo-cache-file cache-url path)) |
d3a65203 LC |
431 | |
432 | (catch 'system-error | |
433 | (lambda () | |
434 | (call-with-input-file cache-file | |
435 | (lambda (p) | |
436 | (match (read p) | |
1cf7e318 | 437 | (('narinfo ('version 2) |
d3a65203 | 438 | ('cache-uri cache-uri) |
5db5dff5 | 439 | ('date date) ('ttl ttl) ('value #f)) |
d3a65203 | 440 | ;; A cached negative lookup. |
5db5dff5 | 441 | (if (obsolete? date now ttl) |
d3a65203 LC |
442 | (values #f #f) |
443 | (values #t #f))) | |
1cf7e318 | 444 | (('narinfo ('version 2) |
d3a65203 | 445 | ('cache-uri cache-uri) |
1cf7e318 | 446 | ('date date) ('ttl ttl) ('value value)) |
d3a65203 | 447 | ;; A cached positive lookup |
1cf7e318 | 448 | (if (obsolete? date now ttl) |
d3a65203 LC |
449 | (values #f #f) |
450 | (values #t (string->narinfo value cache-uri)))) | |
451 | (('narinfo ('version v) _ ...) | |
452 | (values #f #f)))))) | |
453 | (lambda _ | |
454 | (values #f #f)))) | |
455 | ||
23d60ba6 LC |
456 | (define (cache-narinfo! cache-url path narinfo ttl) |
457 | "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the | |
458 | given TTL (a number of seconds or #f). NARINFO may be #f, in which case it | |
459 | indicates that PATH is unavailable at CACHE-URL." | |
d3a65203 LC |
460 | (define now |
461 | (current-time time-monotonic)) | |
eba783b7 | 462 | |
cdea30e0 | 463 | (define (cache-entry cache-uri narinfo) |
1cf7e318 | 464 | `(narinfo (version 2) |
cdea30e0 | 465 | (cache-uri ,cache-uri) |
eba783b7 | 466 | (date ,(time-second now)) |
23d60ba6 LC |
467 | (ttl ,(or ttl |
468 | (if narinfo %narinfo-ttl %narinfo-negative-ttl))) | |
eba783b7 LC |
469 | (value ,(and=> narinfo narinfo->string)))) |
470 | ||
895d1eda | 471 | (let ((file (narinfo-cache-file cache-url path))) |
f10dcbf1 LC |
472 | (mkdir-p (dirname file)) |
473 | (with-atomic-file-output file | |
474 | (lambda (out) | |
475 | (write (cache-entry cache-url narinfo) out)))) | |
895d1eda | 476 | |
d3a65203 LC |
477 | narinfo) |
478 | ||
479 | (define (narinfo-request cache-url path) | |
480 | "Return an HTTP request for the narinfo of PATH at CACHE-URL." | |
481 | (let ((url (string-append cache-url "/" (store-path-hash-part path) | |
f264e838 TGR |
482 | ".narinfo")) |
483 | (headers '((User-Agent . "GNU Guile")))) | |
484 | (build-request (string->uri url) #:method 'GET #:headers headers))) | |
d3a65203 | 485 | |
d213cc8c | 486 | (define (at-most max-length lst) |
5ff52145 LC |
487 | "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise |
488 | return its MAX-LENGTH first elements and its tail." | |
d213cc8c LC |
489 | (let loop ((len 0) |
490 | (lst lst) | |
491 | (result '())) | |
492 | (match lst | |
493 | (() | |
5ff52145 | 494 | (values (reverse result) '())) |
d213cc8c LC |
495 | ((head . tail) |
496 | (if (>= len max-length) | |
5ff52145 | 497 | (values (reverse result) lst) |
d213cc8c LC |
498 | (loop (+ 1 len) tail (cons head result))))))) |
499 | ||
026ca50f | 500 | (define* (http-multiple-get base-uri proc seed requests |
d5abb304 CB |
501 | #:key port (verify-certificate? #t) |
502 | (batch-size 1000)) | |
9b7bd1b1 | 503 | "Send all of REQUESTS to the server at BASE-URI. Call PROC for each |
f151298f LC |
504 | response, passing it the request object, the response, a port from which to |
505 | read the response body, and the previous result, starting with SEED, à la | |
026ca50f LC |
506 | 'fold'. Return the final result. When PORT is specified, use it as the |
507 | initial connection on which HTTP requests are sent." | |
508 | (let connect ((port port) | |
509 | (requests requests) | |
f151298f | 510 | (result seed)) |
9e3f9ac3 | 511 | (define batch |
d5abb304 | 512 | (at-most batch-size requests)) |
9e3f9ac3 | 513 | |
d3a65203 LC |
514 | ;; (format (current-error-port) "connecting (~a requests left)..." |
515 | ;; (length requests)) | |
4fd06a4d LC |
516 | (let ((p (or port (guix:open-connection-for-uri |
517 | base-uri | |
518 | #:verify-certificate? | |
519 | verify-certificate?)))) | |
9b7bd1b1 LC |
520 | ;; For HTTPS, P is not a file port and does not support 'setvbuf'. |
521 | (when (file-port? p) | |
76832d34 | 522 | (setvbuf p 'block (expt 2 16))) |
9b7bd1b1 | 523 | |
9e3f9ac3 | 524 | ;; Send BATCH in a row. |
ec278439 LC |
525 | ;; XXX: Do our own caching to work around inefficiencies when |
526 | ;; communicating over TLS: <http://bugs.gnu.org/22966>. | |
527 | (let-values (((buffer get) (open-bytevector-output-port))) | |
1d84d7bf LC |
528 | ;; Inherit the HTTP proxying property from P. |
529 | (set-http-proxy-port?! buffer (http-proxy-port? p)) | |
ec278439 | 530 | |
d213cc8c | 531 | (for-each (cut write-request <> buffer) |
9e3f9ac3 | 532 | batch) |
ec278439 LC |
533 | (put-bytevector p (get)) |
534 | (force-output p)) | |
d3a65203 LC |
535 | |
536 | ;; Now start processing responses. | |
9e3f9ac3 LC |
537 | (let loop ((sent batch) |
538 | (processed 0) | |
539 | (result result)) | |
540 | (match sent | |
d3a65203 | 541 | (() |
9e3f9ac3 LC |
542 | (match (drop requests processed) |
543 | (() | |
928dc1bb | 544 | (close-port p) |
9e3f9ac3 LC |
545 | (reverse result)) |
546 | (remainder | |
121191f2 | 547 | (connect p remainder result)))) |
d3a65203 | 548 | ((head tail ...) |
075d99f1 AP |
549 | (let* ((resp (read-response p)) |
550 | (body (response-body-port resp)) | |
f151298f | 551 | (result (proc head resp body result))) |
d3a65203 LC |
552 | ;; The server can choose to stop responding at any time, in which |
553 | ;; case we have to try again. Check whether that is the case. | |
075d99f1 | 554 | ;; Note that even upon "Connection: close", we can read from BODY. |
d3a65203 LC |
555 | (match (assq 'connection (response-headers resp)) |
556 | (('connection 'close) | |
f4cde9ac | 557 | (close-port p) |
9e3f9ac3 | 558 | (connect #f ;try again |
e2922f52 | 559 | (drop requests (+ 1 processed)) |
9e3f9ac3 | 560 | result)) |
d3a65203 | 561 | (_ |
9e3f9ac3 | 562 | (loop tail (+ 1 processed) result)))))))))) ;keep going |
d3a65203 LC |
563 | |
564 | (define (read-to-eof port) | |
565 | "Read from PORT until EOF is reached. The data are discarded." | |
566 | (dump-port port (%make-void-port "w"))) | |
567 | ||
568 | (define (narinfo-from-file file url) | |
569 | "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f | |
570 | if file doesn't exist, and the narinfo otherwise." | |
571 | (catch 'system-error | |
572 | (lambda () | |
573 | (call-with-input-file file | |
574 | (cut read-narinfo <> url))) | |
575 | (lambda args | |
576 | (if (= ENOENT (system-error-errno args)) | |
577 | #f | |
578 | (apply throw args))))) | |
579 | ||
4f5234be LC |
580 | (define %unreachable-hosts |
581 | ;; Set of names of unreachable hosts. | |
582 | (make-hash-table)) | |
583 | ||
584 | (define* (open-connection-for-uri/maybe uri | |
585 | #:key | |
586 | (verify-certificate? #f) | |
587 | (time %fetch-timeout)) | |
588 | "Open a connection to URI and return a port to it, or, if connection failed, | |
589 | print a warning and return #f." | |
590 | (define host | |
591 | (uri-host uri)) | |
592 | ||
593 | (catch #t | |
594 | (lambda () | |
595 | (guix:open-connection-for-uri uri | |
596 | #:verify-certificate? verify-certificate? | |
597 | #:timeout time)) | |
598 | (match-lambda* | |
599 | (('getaddrinfo-error error) | |
600 | (unless (hash-ref %unreachable-hosts host) | |
601 | (hash-set! %unreachable-hosts host #t) ;warn only once | |
602 | (warning (G_ "~a: host not found: ~a~%") | |
603 | host (gai-strerror error))) | |
604 | #f) | |
605 | (('system-error . args) | |
606 | (unless (hash-ref %unreachable-hosts host) | |
607 | (hash-set! %unreachable-hosts host #t) | |
608 | (warning (G_ "~a: connection failed: ~a~%") host | |
609 | (strerror | |
610 | (system-error-errno `(system-error ,@args))))) | |
611 | #f) | |
612 | (args | |
613 | (apply throw args))))) | |
614 | ||
074efd63 LC |
615 | (define (fetch-narinfos url paths) |
616 | "Retrieve all the narinfos for PATHS from the cache at URL and return them." | |
d3a65203 | 617 | (define update-progress! |
75a4d86f LC |
618 | (let ((done 0) |
619 | (total (length paths))) | |
d3a65203 | 620 | (lambda () |
4c97a368 | 621 | (display "\r\x1b[K" (current-error-port)) ;erase current line |
d3a65203 LC |
622 | (force-output (current-error-port)) |
623 | (format (current-error-port) | |
2bf9351e | 624 | (G_ "updating substitutes from '~a'... ~5,1f%") |
75a4d86f | 625 | url (* 100. (/ done total))) |
d3a65203 LC |
626 | (set! done (+ 1 done))))) |
627 | ||
3d3e93b3 LC |
628 | (define hash-part->path |
629 | (let ((mapping (fold (lambda (path result) | |
630 | (vhash-cons (store-path-hash-part path) path | |
631 | result)) | |
632 | vlist-null | |
633 | paths))) | |
634 | (lambda (hash) | |
635 | (match (vhash-assoc hash mapping) | |
636 | (#f #f) | |
637 | ((_ . path) path))))) | |
638 | ||
f151298f | 639 | (define (handle-narinfo-response request response port result) |
958fb14c LC |
640 | (let* ((code (response-code response)) |
641 | (len (response-content-length response)) | |
23d60ba6 LC |
642 | (cache (response-cache-control response)) |
643 | (ttl (and cache (assoc-ref cache 'max-age)))) | |
4f5234be LC |
644 | (update-progress!) |
645 | ||
d3a65203 LC |
646 | ;; Make sure to read no more than LEN bytes since subsequent bytes may |
647 | ;; belong to the next response. | |
958fb14c LC |
648 | (if (= code 200) ; hit |
649 | (let ((narinfo (read-narinfo port url #:size len))) | |
4f5234be LC |
650 | (if (string=? (dirname (narinfo-path narinfo)) |
651 | (%store-prefix)) | |
652 | (begin | |
653 | (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) | |
654 | (cons narinfo result)) | |
655 | result)) | |
958fb14c | 656 | (let* ((path (uri-path (request-uri request))) |
a7a3b390 LC |
657 | (hash-part (basename |
658 | (string-drop-right path 8)))) ;drop ".narinfo" | |
958fb14c LC |
659 | (if len |
660 | (get-bytevector-n port len) | |
661 | (read-to-eof port)) | |
3d3e93b3 | 662 | (cache-narinfo! url (hash-part->path hash-part) #f |
504fd36a | 663 | (if (or (= 404 code) (= 202 code)) |
958fb14c LC |
664 | ttl |
665 | %narinfo-transient-error-ttl)) | |
958fb14c | 666 | result)))) |
d3a65203 | 667 | |
4f5234be | 668 | (define (do-fetch uri) |
ae4427e3 | 669 | (case (and=> uri uri-scheme) |
9b7bd1b1 | 670 | ((http https) |
ae4427e3 | 671 | (let ((requests (map (cut narinfo-request url <>) paths))) |
4f5234be LC |
672 | (match (open-connection-for-uri/maybe uri) |
673 | (#f | |
674 | '()) | |
675 | (port | |
676 | (update-progress!) | |
677 | ;; Note: Do not check HTTPS server certificates to avoid depending | |
678 | ;; on the X.509 PKI. We can do it because we authenticate | |
679 | ;; narinfos, which provides a much stronger guarantee. | |
680 | (let ((result (http-multiple-get uri | |
681 | handle-narinfo-response '() | |
682 | requests | |
683 | #:verify-certificate? #f | |
684 | #:port port))) | |
685 | (close-port port) | |
686 | (newline (current-error-port)) | |
687 | result))))) | |
ae4427e3 LC |
688 | ((file #f) |
689 | (let* ((base (string-append (uri-path uri) "/")) | |
690 | (files (map (compose (cut string-append base <> ".narinfo") | |
691 | store-path-hash-part) | |
692 | paths))) | |
693 | (filter-map (cut narinfo-from-file <> url) files))) | |
694 | (else | |
69daee23 | 695 | (leave (G_ "~s: unsupported server URI scheme~%") |
ae4427e3 LC |
696 | (if uri (uri-scheme uri) url))))) |
697 | ||
4f5234be | 698 | (do-fetch (string->uri url))) |
d3a65203 LC |
699 | |
700 | (define (lookup-narinfos cache paths) | |
701 | "Return the narinfos for PATHS, invoking the server at CACHE when no | |
702 | information is available locally." | |
703 | (let-values (((cached missing) | |
704 | (fold2 (lambda (path cached missing) | |
705 | (let-values (((valid? value) | |
895d1eda | 706 | (cached-narinfo cache path))) |
d3a65203 | 707 | (if valid? |
a89dde1e LC |
708 | (if value |
709 | (values (cons value cached) missing) | |
710 | (values cached missing)) | |
d3a65203 LC |
711 | (values cached (cons path missing))))) |
712 | '() | |
713 | '() | |
714 | paths))) | |
715 | (if (null? missing) | |
716 | cached | |
074efd63 LC |
717 | (let ((missing (fetch-narinfos cache missing))) |
718 | (append cached (or missing '())))))) | |
d3a65203 | 719 | |
a9468b42 LC |
720 | (define (equivalent-narinfo? narinfo1 narinfo2) |
721 | "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe | |
722 | the same store item. This ignores unnecessary metadata such as the Nar URL." | |
723 | (and (string=? (narinfo-hash narinfo1) | |
724 | (narinfo-hash narinfo2)) | |
725 | ||
726 | ;; The following is not needed if all we want is to download a valid | |
727 | ;; nar, but it's necessary if we want valid narinfo. | |
728 | (string=? (narinfo-path narinfo1) | |
729 | (narinfo-path narinfo2)) | |
730 | (equal? (narinfo-references narinfo1) | |
731 | (narinfo-references narinfo2)) | |
732 | ||
733 | (= (narinfo-size narinfo1) | |
734 | (narinfo-size narinfo2)))) | |
735 | ||
736 | (define (lookup-narinfos/diverse caches paths authorized?) | |
55b2fc18 | 737 | "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. |
a9468b42 LC |
738 | That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next |
739 | cache, and so on. | |
740 | ||
741 | Return a list of narinfos for PATHS or a subset thereof. The returned | |
742 | narinfos are either AUTHORIZED?, or they claim a hash that matches an | |
743 | AUTHORIZED? narinfo." | |
744 | (define (select-hit result) | |
745 | (lambda (path) | |
746 | (match (vhash-fold* cons '() path result) | |
747 | ((one) | |
748 | one) | |
749 | ((several ..1) | |
750 | (let ((authorized (find authorized? (reverse several)))) | |
751 | (and authorized | |
752 | (find (cut equivalent-narinfo? <> authorized) | |
753 | several))))))) | |
754 | ||
55b2fc18 LC |
755 | (let loop ((caches caches) |
756 | (paths paths) | |
a9468b42 LC |
757 | (result vlist-null) ;path->narinfo vhash |
758 | (hits '())) ;paths | |
55b2fc18 LC |
759 | (match paths |
760 | (() ;we're done | |
a9468b42 LC |
761 | ;; Now iterate on all the HITS, and return exactly one match for each |
762 | ;; hit: the first narinfo that is authorized, or that has the same hash | |
763 | ;; as an authorized narinfo, in the order of CACHES. | |
764 | (filter-map (select-hit result) hits)) | |
55b2fc18 LC |
765 | (_ |
766 | (match caches | |
767 | ((cache rest ...) | |
768 | (let* ((narinfos (lookup-narinfos cache paths)) | |
a9468b42 LC |
769 | (definite (map narinfo-path (filter authorized? narinfos))) |
770 | (missing (lset-difference string=? paths definite))) ;XXX: perf | |
771 | (loop rest missing | |
772 | (fold vhash-cons result | |
773 | (map narinfo-path narinfos) narinfos) | |
774 | (append definite hits)))) | |
55b2fc18 | 775 | (() ;that's it |
a9468b42 | 776 | (filter-map (select-hit result) hits))))))) |
55b2fc18 | 777 | |
a9468b42 | 778 | (define (lookup-narinfo caches path authorized?) |
55b2fc18 LC |
779 | "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH |
780 | was found." | |
a9468b42 | 781 | (match (lookup-narinfos/diverse caches (list path) authorized?) |
55b2fc18 LC |
782 | ((answer) answer) |
783 | (_ #f))) | |
f65cf81a | 784 | |
2ea2aac6 LC |
785 | (define (cached-narinfo-expiration-time file) |
786 | "Return the expiration time for FILE, which is a cached narinfo." | |
787 | (catch 'system-error | |
788 | (lambda () | |
789 | (call-with-input-file file | |
790 | (lambda (port) | |
791 | (match (read port) | |
792 | (('narinfo ('version 2) ('cache-uri uri) | |
793 | ('date date) ('ttl ttl) ('value #f)) | |
5db5dff5 | 794 | (+ date ttl)) |
2ea2aac6 LC |
795 | (('narinfo ('version 2) ('cache-uri uri) |
796 | ('date date) ('ttl ttl) ('value value)) | |
797 | (+ date ttl)) | |
798 | (x | |
799 | 0))))) | |
800 | (lambda args | |
801 | ;; FILE may have been deleted. | |
802 | 0))) | |
4c7cacf1 | 803 | |
2ea2aac6 | 804 | (define (narinfo-cache-directories directory) |
895d1eda | 805 | "Return the list of narinfo cache directories (one per cache URL.)" |
2ea2aac6 | 806 | (map (cut string-append directory "/" <>) |
895d1eda LC |
807 | (scandir %narinfo-cache-directory |
808 | (lambda (item) | |
809 | (and (not (member item '("." ".."))) | |
810 | (file-is-directory? | |
811 | (string-append %narinfo-cache-directory | |
812 | "/" item))))))) | |
813 | ||
2ea2aac6 LC |
814 | (define* (cached-narinfo-files #:optional |
815 | (directory %narinfo-cache-directory)) | |
816 | "Return the list of cached narinfo files under DIRECTORY." | |
817 | (append-map (lambda (directory) | |
818 | (map (cut string-append directory "/" <>) | |
819 | (scandir directory | |
820 | (lambda (file) | |
821 | (= (string-length file) 32))))) | |
822 | (narinfo-cache-directories directory))) | |
4c7cacf1 | 823 | |
cf5d2ca3 LC |
824 | (define-syntax with-networking |
825 | (syntax-rules () | |
8c321299 | 826 | "Catch DNS lookup errors and TLS errors and gracefully exit." |
cf5d2ca3 LC |
827 | ;; Note: no attempt is made to catch other networking errors, because DNS |
828 | ;; lookup errors are typically the first one, and because other errors are | |
829 | ;; a subset of `system-error', which is harder to filter. | |
830 | ((_ exp ...) | |
8c321299 | 831 | (catch #t |
cf5d2ca3 | 832 | (lambda () exp ...) |
8c321299 LC |
833 | (match-lambda* |
834 | (('getaddrinfo-error error) | |
69daee23 | 835 | (leave (G_ "host name lookup error: ~a~%") |
8c321299 LC |
836 | (gai-strerror error))) |
837 | (('gnutls-error error proc . rest) | |
838 | (let ((error->string (module-ref (resolve-interface '(gnutls)) | |
839 | 'error->string))) | |
69daee23 | 840 | (leave (G_ "TLS error in procedure '~a': ~a~%") |
8c321299 LC |
841 | proc (error->string error)))) |
842 | (args | |
843 | (apply throw args))))))) | |
cf5d2ca3 | 844 | |
f65cf81a | 845 | \f |
29479de5 LC |
846 | ;;; |
847 | ;;; Help. | |
848 | ;;; | |
849 | ||
850 | (define (show-help) | |
69daee23 | 851 | (display (G_ "Usage: guix substitute [OPTION]... |
29479de5 | 852 | Internal tool to substitute a pre-built binary to a local build.\n")) |
69daee23 | 853 | (display (G_ " |
29479de5 LC |
854 | --query report on the availability of substitutes for the |
855 | store file names passed on the standard input")) | |
69daee23 | 856 | (display (G_ " |
29479de5 LC |
857 | --substitute STORE-FILE DESTINATION |
858 | download STORE-FILE and store it as a Nar in file | |
859 | DESTINATION")) | |
860 | (newline) | |
69daee23 | 861 | (display (G_ " |
29479de5 | 862 | -h, --help display this help and exit")) |
69daee23 | 863 | (display (G_ " |
29479de5 LC |
864 | -V, --version display version information and exit")) |
865 | (newline) | |
866 | (show-bug-report-information)) | |
867 | ||
868 | ||
869 | \f | |
ef8f910f LC |
870 | ;;; |
871 | ;;; Daemon/substituter protocol. | |
872 | ;;; | |
873 | ||
874 | (define (display-narinfo-data narinfo) | |
9d2f48df | 875 | "Write to the current output port the contents of NARINFO in the format |
ef8f910f LC |
876 | expected by the daemon." |
877 | (format #t "~a\n~a\n~a\n" | |
878 | (narinfo-path narinfo) | |
879 | (or (and=> (narinfo-deriver narinfo) | |
880 | (cute string-append (%store-prefix) "/" <>)) | |
881 | "") | |
882 | (length (narinfo-references narinfo))) | |
883 | (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) | |
884 | (narinfo-references narinfo)) | |
b90ae065 | 885 | |
4736d06f | 886 | (let-values (((uri compression file-size) (narinfo-best-uri narinfo))) |
b90ae065 LC |
887 | (format #t "~a\n~a\n" |
888 | (or file-size 0) | |
889 | (or (narinfo-size narinfo) 0)))) | |
ef8f910f LC |
890 | |
891 | (define* (process-query command | |
55b2fc18 | 892 | #:key cache-urls acl) |
ef8f910f LC |
893 | "Reply to COMMAND, a query as written by the daemon to this process's |
894 | standard input. Use ACL as the access-control list against which to check | |
895 | authorized substitutes." | |
896 | (define (valid? obj) | |
55b2fc18 | 897 | (valid-narinfo? obj acl)) |
ef8f910f | 898 | |
79c6614f LC |
899 | (when (%allow-unauthenticated-substitutes?) |
900 | (warn-about-missing-authentication)) | |
901 | ||
ef8f910f LC |
902 | (match (string-tokenize command) |
903 | (("have" paths ..1) | |
55b2fc18 | 904 | ;; Return the subset of PATHS available in CACHE-URLS. |
a9468b42 | 905 | (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) |
ef8f910f LC |
906 | (for-each (lambda (narinfo) |
907 | (format #t "~a~%" (narinfo-path narinfo))) | |
a9468b42 | 908 | substitutable) |
ef8f910f LC |
909 | (newline))) |
910 | (("info" paths ..1) | |
55b2fc18 | 911 | ;; Reply info about PATHS if it's in CACHE-URLS. |
a9468b42 LC |
912 | (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) |
913 | (for-each display-narinfo-data substitutable) | |
ef8f910f LC |
914 | (newline))) |
915 | (wtf | |
916 | (error "unknown `--query' command" wtf)))) | |
917 | ||
b90ae065 LC |
918 | (define %compression-methods |
919 | ;; Known compression methods and a thunk to determine whether they're | |
920 | ;; supported. See 'decompressed-port' in (guix utils). | |
921 | `(("gzip" . ,(const #t)) | |
4c0c65ac | 922 | ("lzip" . ,(const #t)) |
b90ae065 LC |
923 | ("xz" . ,(const #t)) |
924 | ("bzip2" . ,(const #t)) | |
925 | ("none" . ,(const #t)))) | |
926 | ||
927 | (define (supported-compression? compression) | |
928 | "Return true if COMPRESSION, a string, denotes a supported compression | |
929 | method." | |
930 | (match (assoc-ref %compression-methods compression) | |
931 | (#f #f) | |
932 | (supported? (supported?)))) | |
933 | ||
934 | (define (compresses-better? compression1 compression2) | |
935 | "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; | |
936 | this is a rough approximation." | |
937 | (match compression1 | |
938 | ("none" #f) | |
939 | ("gzip" (string=? compression2 "none")) | |
940 | (_ (or (string=? compression2 "none") | |
941 | (string=? compression2 "gzip"))))) | |
942 | ||
4736d06f | 943 | (define (narinfo-best-uri narinfo) |
b90ae065 LC |
944 | "Select the \"best\" URI to download NARINFO's nar, and return three values: |
945 | the URI, its compression method (a string), and the compressed file size." | |
946 | (define choices | |
947 | (filter (match-lambda | |
948 | ((uri compression file-size) | |
949 | (supported-compression? compression))) | |
950 | (zip (narinfo-uris narinfo) | |
951 | (narinfo-compressions narinfo) | |
952 | (narinfo-file-sizes narinfo)))) | |
953 | ||
954 | (define (file-size<? c1 c2) | |
955 | (match c1 | |
956 | ((uri1 compression1 (? integer? file-size1)) | |
957 | (match c2 | |
958 | ((uri2 compression2 (? integer? file-size2)) | |
959 | (< file-size1 file-size2)) | |
960 | (_ #t))) | |
961 | ((uri compression1 #f) | |
962 | (match c2 | |
963 | ((uri2 compression2 _) | |
964 | (compresses-better? compression1 compression2)))) | |
965 | (_ #f))) ;we can't tell | |
966 | ||
967 | (match (sort choices file-size<?) | |
968 | (((uri compression file-size) _ ...) | |
969 | (values uri compression file-size)))) | |
970 | ||
5ff52145 LC |
971 | (define %max-cached-connections |
972 | ;; Maximum number of connections kept in cache by | |
973 | ;; 'open-connection-for-uri/cached'. | |
974 | 16) | |
975 | ||
976 | (define open-connection-for-uri/cached | |
977 | (let ((cache '())) | |
978 | (lambda* (uri #:key fresh?) | |
979 | "Return a connection for URI, possibly reusing a cached connection. | |
980 | When FRESH? is true, delete any cached connections for URI and open a new | |
981 | one. Return #f if URI's scheme is 'file' or #f." | |
982 | (define host (uri-host uri)) | |
983 | (define scheme (uri-scheme uri)) | |
984 | (define key (list host scheme (uri-port uri))) | |
985 | ||
986 | (and (not (memq scheme '(file #f))) | |
987 | (match (assoc-ref cache key) | |
988 | (#f | |
989 | ;; Open a new connection to URI and evict old entries from | |
990 | ;; CACHE, if any. | |
991 | (let-values (((socket) | |
992 | (guix:open-connection-for-uri | |
993 | uri #:verify-certificate? #f)) | |
994 | ((new-cache evicted) | |
995 | (at-most (- %max-cached-connections 1) cache))) | |
996 | (for-each (match-lambda | |
997 | ((_ . port) | |
998 | (false-if-exception (close-port port)))) | |
999 | evicted) | |
1000 | (set! cache (alist-cons key socket new-cache)) | |
1001 | socket)) | |
1002 | (socket | |
1003 | (if (or fresh? (port-closed? socket)) | |
1004 | (begin | |
1005 | (false-if-exception (close-port socket)) | |
1006 | (set! cache (alist-delete key cache)) | |
1007 | (open-connection-for-uri/cached uri)) | |
1008 | (begin | |
1009 | ;; Drain input left from the previous use. | |
1010 | (drain-input socket) | |
1011 | socket)))))))) | |
1012 | ||
1013 | (define (call-with-cached-connection uri proc) | |
1014 | (let ((port (open-connection-for-uri/cached uri))) | |
1015 | (catch #t | |
1016 | (lambda () | |
1017 | (proc port)) | |
1018 | (lambda (key . args) | |
1019 | ;; If PORT was cached and the server closed the connection in the | |
1020 | ;; meantime, we get EPIPE. In that case, open a fresh connection and | |
1021 | ;; retry. We might also get 'bad-response or a similar exception from | |
1022 | ;; (web response) later on, once we've sent the request. | |
1023 | (if (or (and (eq? key 'system-error) | |
1024 | (= EPIPE (system-error-errno `(,key ,@args)))) | |
1025 | (memq key '(bad-response bad-header bad-header-component))) | |
1026 | (proc (open-connection-for-uri/cached uri #:fresh? #t)) | |
1027 | (apply throw key args)))))) | |
1028 | ||
1029 | (define-syntax-rule (with-cached-connection uri port exp ...) | |
1030 | "Bind PORT with EXP... to a socket connected to URI." | |
1031 | (call-with-cached-connection uri (lambda (port) exp ...))) | |
1032 | ||
ef8f910f | 1033 | (define* (process-substitution store-item destination |
dc0f74e5 | 1034 | #:key cache-urls acl print-build-trace?) |
55b2fc18 | 1035 | "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to |
ef8f910f | 1036 | DESTINATION as a nar file. Verify the substitute against ACL." |
b90ae065 LC |
1037 | (define narinfo |
1038 | (lookup-narinfo cache-urls store-item | |
1039 | (cut valid-narinfo? <> acl))) | |
1040 | ||
1041 | (unless narinfo | |
1042 | (leave (G_ "no valid substitute for '~a'~%") | |
1043 | store-item)) | |
ef8f910f | 1044 | |
b90ae065 | 1045 | (let-values (((uri compression file-size) |
4736d06f | 1046 | (narinfo-best-uri narinfo))) |
ef8f910f LC |
1047 | ;; Tell the daemon what the expected hash of the Nar itself is. |
1048 | (format #t "~a~%" (narinfo-hash narinfo)) | |
1049 | ||
dc0f74e5 LC |
1050 | (unless print-build-trace? |
1051 | (format (current-error-port) | |
1052 | (G_ "Downloading ~a...~%") (uri->string uri))) | |
1053 | ||
ef8f910f | 1054 | (let*-values (((raw download-size) |
5ff52145 LC |
1055 | ;; 'guix publish' without '--cache' doesn't specify a |
1056 | ;; Content-Length, so DOWNLOAD-SIZE is #f in this case. | |
1057 | (with-cached-connection uri port | |
1058 | (fetch uri #:buffered? #f #:timeout? #f | |
1059 | #:port port | |
1060 | #:keep-alive? #t))) | |
ef8f910f | 1061 | ((progress) |
b90ae065 LC |
1062 | (let* ((dl-size (or download-size |
1063 | (and (equal? compression "none") | |
ef8f910f | 1064 | (narinfo-size narinfo)))) |
dc0f74e5 LC |
1065 | (reporter (if print-build-trace? |
1066 | (progress-reporter/trace | |
1067 | destination | |
1068 | (uri->string uri) dl-size | |
1069 | (current-error-port)) | |
1070 | (progress-reporter/file | |
1071 | (uri->string uri) dl-size | |
1072 | (current-error-port) | |
1073 | #:abbreviation nar-uri-abbreviation)))) | |
5ff52145 LC |
1074 | ;; Keep RAW open upon completion so we can later reuse |
1075 | ;; the underlying connection. | |
1076 | (progress-report-port reporter raw #:close? #f))) | |
ef8f910f | 1077 | ((input pids) |
5efa0e4d SB |
1078 | ;; NOTE: This 'progress' port of current process will be |
1079 | ;; closed here, while the child process doing the | |
1080 | ;; reporting will close it upon exit. | |
b90ae065 | 1081 | (decompressed-port (string->symbol compression) |
ef8f910f LC |
1082 | progress))) |
1083 | ;; Unpack the Nar at INPUT into DESTINATION. | |
1084 | (restore-file input destination) | |
4220514b | 1085 | (close-port input) |
5efa0e4d SB |
1086 | |
1087 | ;; Wait for the reporter to finish. | |
1088 | (every (compose zero? cdr waitpid) pids) | |
ef8f910f | 1089 | |
79864851 SB |
1090 | ;; Skip a line after what 'progress-reporter/file' printed, and another |
1091 | ;; one to visually separate substitutions. | |
711df9ef LC |
1092 | (display "\n\n" (current-error-port)) |
1093 | ||
1094 | ;; Tell the daemon that we're done. | |
1095 | (display "success\n" (current-output-port))))) | |
ef8f910f LC |
1096 | |
1097 | \f | |
f65cf81a LC |
1098 | ;;; |
1099 | ;;; Entry point. | |
1100 | ;;; | |
1101 | ||
cdea30e0 LC |
1102 | (define (check-acl-initialized) |
1103 | "Warn if the ACL is uninitialized." | |
1104 | (define (singleton? acl) | |
1105 | ;; True if ACL contains just the user's public key. | |
1106 | (and (file-exists? %public-key-file) | |
1107 | (let ((key (call-with-input-file %public-key-file | |
1108 | (compose string->canonical-sexp | |
2535635f | 1109 | read-string)))) |
00fe9333 LC |
1110 | (match acl |
1111 | ((thing) | |
1112 | (equal? (canonical-sexp->string thing) | |
1113 | (canonical-sexp->string key))) | |
1114 | (_ | |
1115 | #f))))) | |
1116 | ||
1117 | (let ((acl (acl->public-keys (current-acl)))) | |
cdea30e0 | 1118 | (when (or (null? acl) (singleton? acl)) |
69daee23 | 1119 | (warning (G_ "ACL for archive imports seems to be uninitialized, \ |
cdea30e0 LC |
1120 | substitutes may be unavailable\n"))))) |
1121 | ||
9176607e LC |
1122 | (define (daemon-options) |
1123 | "Return a list of name/value pairs denoting build daemon options." | |
1124 | (define %not-newline | |
1125 | (char-set-complement (char-set #\newline))) | |
1126 | ||
1127 | (match (getenv "_NIX_OPTIONS") | |
1128 | (#f ;should not happen when called by the daemon | |
1129 | '()) | |
1130 | (newline-separated | |
1131 | ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n". | |
1132 | (filter-map (lambda (option=value) | |
1133 | (match (string-index option=value #\=) | |
1134 | (#f ;invalid option setting | |
1135 | #f) | |
1136 | (equal-sign | |
1137 | (cons (string-take option=value equal-sign) | |
1138 | (string-drop option=value (+ 1 equal-sign)))))) | |
1139 | (string-tokenize newline-separated %not-newline))))) | |
1140 | ||
1141 | (define (find-daemon-option option) | |
1142 | "Return the value of build daemon option OPTION, or #f if it could not be | |
1143 | found." | |
1144 | (assoc-ref (daemon-options) option)) | |
1145 | ||
218f6ecc | 1146 | (define %default-substitute-urls |
71e2065a LC |
1147 | (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client |
1148 | (find-daemon-option "substitute-urls")) ;admin | |
4938b0ee | 1149 | string-tokenize) |
55b2fc18 LC |
1150 | ((urls ...) |
1151 | urls) | |
4938b0ee LC |
1152 | (#f |
1153 | ;; This can only happen when this script is not invoked by the | |
1154 | ;; daemon. | |
757e633d | 1155 | '("http://ci.guix.gnu.org")))) |
9176607e | 1156 | |
79f9dee3 MO |
1157 | ;; In order to prevent using large number of discovered local substitute |
1158 | ;; servers, limit the local substitute urls list size. | |
1159 | (define %max-substitute-urls 50) | |
1160 | ||
1161 | (define* (randomize-substitute-urls urls | |
1162 | #:key | |
1163 | (max %max-substitute-urls)) | |
1164 | "Return a list containing MAX urls from URLS, picked randomly. If URLS list | |
1165 | is shorter than MAX elements, then it is directly returned." | |
1166 | (define (random-item list) | |
1167 | (list-ref list (random (length list)))) | |
1168 | ||
1169 | (if (<= (length urls) max) | |
1170 | urls | |
1171 | (let loop ((res '()) | |
1172 | (urls urls)) | |
1173 | (if (eq? (length res) max) | |
1174 | res | |
1175 | (let ((url (random-item urls))) | |
1176 | (loop (cons url res) (delete url urls))))))) | |
1177 | ||
1178 | (define %local-substitute-urls | |
1179 | ;; If the following option is passed to the daemon, use the substitutes list | |
1180 | ;; provided by "guix discover" process. | |
79fd9f40 MO |
1181 | (let* ((option (find-daemon-option "discover")) |
1182 | (discover? (and option (string=? option "yes")))) | |
1183 | (if discover? | |
1184 | (randomize-substitute-urls (read-substitute-urls)) | |
1185 | '()))) | |
79f9dee3 | 1186 | |
218f6ecc LC |
1187 | (define substitute-urls |
1188 | ;; List of substitute URLs. | |
79f9dee3 MO |
1189 | (make-parameter (append %local-substitute-urls |
1190 | %default-substitute-urls))) | |
218f6ecc | 1191 | |
b0a6a971 LC |
1192 | (define (client-terminal-columns) |
1193 | "Return the number of columns in the client's terminal, if it is known, or a | |
1194 | default value." | |
1195 | (or (and=> (or (find-daemon-option "untrusted-terminal-columns") | |
1196 | (find-daemon-option "terminal-columns")) | |
85fc958d LC |
1197 | (lambda (str) |
1198 | (let ((number (string->number str))) | |
1199 | (and number (max 20 (- number 1)))))) | |
b0a6a971 LC |
1200 | 80)) |
1201 | ||
8a210507 LC |
1202 | (define (validate-uri uri) |
1203 | (unless (string->uri uri) | |
69daee23 | 1204 | (leave (G_ "~a: invalid URI~%") uri))) |
8a210507 | 1205 | |
711df9ef LC |
1206 | (define %error-to-file-descriptor-4? |
1207 | ;; Whether to direct 'current-error-port' to file descriptor 4 like | |
1208 | ;; 'guix-daemon' expects. | |
1209 | (make-parameter #t)) | |
1210 | ||
3794ce93 LC |
1211 | (define-command (guix-substitute . args) |
1212 | (category internal) | |
1213 | (synopsis "implement the build daemon's substituter protocol") | |
1214 | ||
dc0f74e5 LC |
1215 | (define print-build-trace? |
1216 | (match (or (find-daemon-option "untrusted-print-extended-build-trace") | |
1217 | (find-daemon-option "print-extended-build-trace")) | |
1218 | (#f #f) | |
1219 | ((= string->number number) (> number 0)) | |
1220 | (_ #f))) | |
1221 | ||
79c6614f LC |
1222 | ;; The daemon's agent code opens file descriptor 4 for us and this is where |
1223 | ;; stderr should go. | |
711df9ef LC |
1224 | (parameterize ((current-error-port (if (%error-to-file-descriptor-4?) |
1225 | (fdopen 4 "wl") | |
1226 | (current-error-port)))) | |
79c6614f LC |
1227 | ;; Redirect diagnostics to file descriptor 4 as well. |
1228 | (guix-warning-port (current-error-port)) | |
1229 | ||
1230 | (mkdir-p %narinfo-cache-directory) | |
1231 | (maybe-remove-expired-cache-entries %narinfo-cache-directory | |
1232 | cached-narinfo-files | |
1233 | #:entry-expiration | |
1234 | cached-narinfo-expiration-time | |
1235 | #:cleanup-period | |
1236 | %narinfo-expired-cache-entry-removal-delay) | |
1237 | (check-acl-initialized) | |
1238 | ||
1239 | ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error | |
1240 | ;; message. | |
1241 | (for-each validate-uri (substitute-urls)) | |
1242 | ||
1243 | ;; Attempt to install the client's locale so that messages are suitably | |
1244 | ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default | |
1245 | ;; so don't change it. | |
1246 | (match (or (find-daemon-option "untrusted-locale") | |
1247 | (find-daemon-option "locale")) | |
1248 | (#f #f) | |
1249 | (locale (false-if-exception (setlocale LC_MESSAGES locale)))) | |
1250 | ||
1251 | (catch 'system-error | |
1252 | (lambda () | |
1253 | (set-thread-name "guix substitute")) | |
1254 | (const #t)) ;GNU/Hurd lacks 'prctl' | |
1255 | ||
1256 | (with-networking | |
1257 | (with-error-handling ; for signature errors | |
1258 | (match args | |
1259 | (("--query") | |
1260 | (let ((acl (current-acl))) | |
1261 | (let loop ((command (read-line))) | |
1262 | (or (eof-object? command) | |
1263 | (begin | |
1264 | (process-query command | |
1265 | #:cache-urls (substitute-urls) | |
1266 | #:acl acl) | |
1267 | (loop (read-line))))))) | |
711df9ef | 1268 | (("--substitute") |
79c6614f LC |
1269 | ;; Download STORE-PATH and store it as a Nar in file DESTINATION. |
1270 | ;; Specify the number of columns of the terminal so the progress | |
1271 | ;; report displays nicely. | |
1272 | (parameterize ((current-terminal-columns (client-terminal-columns))) | |
711df9ef LC |
1273 | (let loop () |
1274 | (match (read-line) | |
1275 | ((? eof-object?) | |
1276 | #t) | |
1277 | ((= string-tokenize ("substitute" store-path destination)) | |
1278 | (process-substitution store-path destination | |
1279 | #:cache-urls (substitute-urls) | |
1280 | #:acl (current-acl) | |
1281 | #:print-build-trace? | |
1282 | print-build-trace?) | |
1283 | (loop)))))) | |
79c6614f LC |
1284 | ((or ("-V") ("--version")) |
1285 | (show-version-and-exit "guix substitute")) | |
1286 | (("--help") | |
1287 | (show-help)) | |
1288 | (opts | |
1289 | (leave (G_ "~a: unrecognized options~%") opts))))))) | |
f65cf81a | 1290 | |
bb7dcaea | 1291 | ;;; Local Variables: |
2207f731 | 1292 | ;;; eval: (put 'with-timeout 'scheme-indent-function 1) |
5ff52145 | 1293 | ;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) |
ae3b6bb0 LC |
1294 | ;;; End: |
1295 | ||
2c74fde0 | 1296 | ;;; substitute.scm ends here |