Commit | Line | Data |
---|---|---|
f65cf81a | 1 | ;;; GNU Guix --- Functional package management for GNU |
e2572aa9 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
e9c6c584 | 3 | ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
7ede577a | 4 | ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> |
35e0c0cf | 5 | ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> |
f65cf81a LC |
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 | ||
2c74fde0 | 22 | (define-module (guix scripts substitute) |
f65cf81a | 23 | #:use-module (guix ui) |
3794ce93 | 24 | #:use-module (guix scripts) |
681af174 | 25 | #:use-module (guix narinfo) |
f4cde9ac | 26 | #:use-module (guix store) |
112692c0 | 27 | #:use-module (guix substitutes) |
f65cf81a | 28 | #:use-module (guix utils) |
958dd3ce | 29 | #:use-module (guix combinators) |
fe0cff14 | 30 | #:use-module (guix config) |
c0cd1b3e | 31 | #:use-module (guix records) |
9dfa20a2 LC |
32 | #:use-module (guix diagnostics) |
33 | #:use-module (guix i18n) | |
c7c7f068 LC |
34 | #:use-module ((guix serialization) #:select (restore-file dump-file)) |
35 | #:autoload (guix store deduplication) (dump-file/deduplicate) | |
35a32fef | 36 | #:autoload (guix scripts discover) (read-substitute-urls) |
ca719424 | 37 | #:use-module (gcrypt hash) |
895d1eda | 38 | #:use-module (guix base32) |
e9c6c584 | 39 | #:use-module (guix base64) |
2ea2aac6 | 40 | #:use-module (guix cache) |
ca719424 | 41 | #:use-module (gcrypt pk-crypto) |
e9c6c584 | 42 | #:use-module (guix pki) |
112692c0 | 43 | #:use-module ((guix build utils) #:select (mkdir-p)) |
a85060ef | 44 | #:use-module ((guix build download) |
8c348825 | 45 | #:select (uri-abbreviation nar-uri-abbreviation |
4fd06a4d | 46 | (open-connection-for-uri |
112692c0 | 47 | . guix:open-connection-for-uri))) |
8c348825 | 48 | #:use-module (guix progress) |
8902d0f2 LC |
49 | #:use-module ((guix build syscalls) |
50 | #:select (set-thread-name)) | |
f65cf81a | 51 | #:use-module (ice-9 rdelim) |
f65cf81a | 52 | #:use-module (ice-9 match) |
fe0cff14 | 53 | #:use-module (ice-9 format) |
4c7cacf1 | 54 | #:use-module (ice-9 ftw) |
e9c6c584 | 55 | #:use-module (rnrs bytevectors) |
f65cf81a | 56 | #:use-module (srfi srfi-1) |
f65cf81a | 57 | #:use-module (srfi srfi-11) |
eba783b7 | 58 | #:use-module (srfi srfi-19) |
f65cf81a | 59 | #:use-module (srfi srfi-26) |
706e9e57 | 60 | #:use-module (srfi srfi-34) |
e9c6c584 | 61 | #:use-module (srfi srfi-35) |
f65cf81a | 62 | #:use-module (web uri) |
3b8258c5 | 63 | #:use-module (guix http-client) |
112692c0 | 64 | #:export (%allow-unauthenticated-substitutes? |
711df9ef | 65 | %error-to-file-descriptor-4? |
434138e2 | 66 | |
218f6ecc | 67 | substitute-urls |
2c74fde0 | 68 | guix-substitute)) |
f65cf81a LC |
69 | |
70 | ;;; Comment: | |
71 | ;;; | |
72 | ;;; This is the "binary substituter". It is invoked by the daemon do check | |
73 | ;;; for the existence of available "substitutes" (pre-built binaries), and to | |
74 | ;;; actually use them as a substitute to building things locally. | |
75 | ;;; | |
76 | ;;; If possible, substitute a binary for the requested store path, using a Nix | |
77 | ;;; "binary cache". This program implements the Nix "substituter" protocol. | |
78 | ;;; | |
79 | ;;; Code: | |
80 | ||
112692c0 CB |
81 | (define %narinfo-expired-cache-entry-removal-delay |
82 | ;; How often we want to remove files corresponding to expired cache entries. | |
83 | (* 7 24 3600)) | |
eba783b7 | 84 | |
434138e2 LC |
85 | (define (warn-about-missing-authentication) |
86 | (warning (G_ "authentication and authorization of substitutes \ | |
87 | disabled!~%")) | |
88 | #t) | |
89 | ||
e9c6c584 NK |
90 | (define %allow-unauthenticated-substitutes? |
91 | ;; Whether to allow unchecked substitutes. This is useful for testing | |
92 | ;; purposes, and should be avoided otherwise. | |
434138e2 LC |
93 | (make-parameter |
94 | (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") | |
79c6614f | 95 | (cut string-ci=? <> "yes")))) |
e9c6c584 | 96 | |
2207f731 LC |
97 | (define %fetch-timeout |
98 | ;; Number of seconds after which networking is considered "slow". | |
8b79e2e6 | 99 | 5) |
2207f731 | 100 | |
bb7dcaea LC |
101 | (define %random-state |
102 | (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) | |
103 | ||
2207f731 LC |
104 | (define-syntax-rule (with-timeout duration handler body ...) |
105 | "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY | |
106 | again." | |
107 | (begin | |
108 | (sigaction SIGALRM | |
109 | (lambda (signum) | |
110 | (sigaction SIGALRM SIG_DFL) | |
111 | handler)) | |
112 | (alarm duration) | |
113 | (call-with-values | |
114 | (lambda () | |
115 | (let try () | |
116 | (catch 'system-error | |
117 | (lambda () | |
118 | body ...) | |
119 | (lambda args | |
c509bf8c LC |
120 | ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR |
121 | ;; because of the bug at | |
bb7dcaea LC |
122 | ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>. |
123 | ;; When that happens, try again. Note: SA_RESTART cannot be | |
124 | ;; used because of <http://bugs.gnu.org/14640>. | |
2207f731 | 125 | (if (= EINTR (system-error-errno args)) |
bb7dcaea LC |
126 | (begin |
127 | ;; Wait a little to avoid bursts. | |
128 | (usleep (random 3000000 %random-state)) | |
129 | (try)) | |
2207f731 LC |
130 | (apply throw args)))))) |
131 | (lambda result | |
132 | (alarm 0) | |
133 | (sigaction SIGALRM SIG_DFL) | |
134 | (apply values result))))) | |
135 | ||
d213cc8c | 136 | (define (at-most max-length lst) |
5ff52145 LC |
137 | "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise |
138 | return its MAX-LENGTH first elements and its tail." | |
d213cc8c LC |
139 | (let loop ((len 0) |
140 | (lst lst) | |
141 | (result '())) | |
142 | (match lst | |
143 | (() | |
5ff52145 | 144 | (values (reverse result) '())) |
d213cc8c LC |
145 | ((head . tail) |
146 | (if (>= len max-length) | |
5ff52145 | 147 | (values (reverse result) lst) |
d213cc8c LC |
148 | (loop (+ 1 len) tail (cons head result))))))) |
149 | ||
d3a65203 LC |
150 | (define (narinfo-from-file file url) |
151 | "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f | |
152 | if file doesn't exist, and the narinfo otherwise." | |
153 | (catch 'system-error | |
154 | (lambda () | |
155 | (call-with-input-file file | |
156 | (cut read-narinfo <> url))) | |
157 | (lambda args | |
158 | (if (= ENOENT (system-error-errno args)) | |
159 | #f | |
160 | (apply throw args))))) | |
161 | ||
a9468b42 | 162 | (define (lookup-narinfo caches path authorized?) |
55b2fc18 LC |
163 | "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH |
164 | was found." | |
a9468b42 | 165 | (match (lookup-narinfos/diverse caches (list path) authorized?) |
55b2fc18 LC |
166 | ((answer) answer) |
167 | (_ #f))) | |
f65cf81a | 168 | |
2ea2aac6 LC |
169 | (define (cached-narinfo-expiration-time file) |
170 | "Return the expiration time for FILE, which is a cached narinfo." | |
171 | (catch 'system-error | |
172 | (lambda () | |
173 | (call-with-input-file file | |
174 | (lambda (port) | |
175 | (match (read port) | |
176 | (('narinfo ('version 2) ('cache-uri uri) | |
177 | ('date date) ('ttl ttl) ('value #f)) | |
5db5dff5 | 178 | (+ date ttl)) |
2ea2aac6 LC |
179 | (('narinfo ('version 2) ('cache-uri uri) |
180 | ('date date) ('ttl ttl) ('value value)) | |
181 | (+ date ttl)) | |
182 | (x | |
183 | 0))))) | |
184 | (lambda args | |
185 | ;; FILE may have been deleted. | |
186 | 0))) | |
4c7cacf1 | 187 | |
2ea2aac6 | 188 | (define (narinfo-cache-directories directory) |
895d1eda | 189 | "Return the list of narinfo cache directories (one per cache URL.)" |
2ea2aac6 | 190 | (map (cut string-append directory "/" <>) |
895d1eda LC |
191 | (scandir %narinfo-cache-directory |
192 | (lambda (item) | |
193 | (and (not (member item '("." ".."))) | |
194 | (file-is-directory? | |
195 | (string-append %narinfo-cache-directory | |
196 | "/" item))))))) | |
197 | ||
2ea2aac6 LC |
198 | (define* (cached-narinfo-files #:optional |
199 | (directory %narinfo-cache-directory)) | |
200 | "Return the list of cached narinfo files under DIRECTORY." | |
201 | (append-map (lambda (directory) | |
202 | (map (cut string-append directory "/" <>) | |
203 | (scandir directory | |
204 | (lambda (file) | |
205 | (= (string-length file) 32))))) | |
206 | (narinfo-cache-directories directory))) | |
4c7cacf1 | 207 | |
cf5d2ca3 LC |
208 | (define-syntax with-networking |
209 | (syntax-rules () | |
8c321299 | 210 | "Catch DNS lookup errors and TLS errors and gracefully exit." |
cf5d2ca3 LC |
211 | ;; Note: no attempt is made to catch other networking errors, because DNS |
212 | ;; lookup errors are typically the first one, and because other errors are | |
213 | ;; a subset of `system-error', which is harder to filter. | |
214 | ((_ exp ...) | |
e2572aa9 LC |
215 | ;; Use a pre-unwind handler so that re-throwing preserves useful |
216 | ;; backtraces. 'with-throw-handler' works for Guile 2.2 and 3.0. | |
217 | (with-throw-handler #t | |
cf5d2ca3 | 218 | (lambda () exp ...) |
8c321299 LC |
219 | (match-lambda* |
220 | (('getaddrinfo-error error) | |
69daee23 | 221 | (leave (G_ "host name lookup error: ~a~%") |
8c321299 LC |
222 | (gai-strerror error))) |
223 | (('gnutls-error error proc . rest) | |
224 | (let ((error->string (module-ref (resolve-interface '(gnutls)) | |
225 | 'error->string))) | |
69daee23 | 226 | (leave (G_ "TLS error in procedure '~a': ~a~%") |
8c321299 LC |
227 | proc (error->string error)))) |
228 | (args | |
229 | (apply throw args))))))) | |
cf5d2ca3 | 230 | |
f65cf81a | 231 | \f |
29479de5 LC |
232 | ;;; |
233 | ;;; Help. | |
234 | ;;; | |
235 | ||
236 | (define (show-help) | |
69daee23 | 237 | (display (G_ "Usage: guix substitute [OPTION]... |
29479de5 | 238 | Internal tool to substitute a pre-built binary to a local build.\n")) |
69daee23 | 239 | (display (G_ " |
29479de5 LC |
240 | --query report on the availability of substitutes for the |
241 | store file names passed on the standard input")) | |
69daee23 | 242 | (display (G_ " |
29479de5 LC |
243 | --substitute STORE-FILE DESTINATION |
244 | download STORE-FILE and store it as a Nar in file | |
245 | DESTINATION")) | |
246 | (newline) | |
69daee23 | 247 | (display (G_ " |
29479de5 | 248 | -h, --help display this help and exit")) |
69daee23 | 249 | (display (G_ " |
29479de5 LC |
250 | -V, --version display version information and exit")) |
251 | (newline) | |
252 | (show-bug-report-information)) | |
253 | ||
254 | ||
255 | \f | |
ef8f910f LC |
256 | ;;; |
257 | ;;; Daemon/substituter protocol. | |
258 | ;;; | |
259 | ||
260 | (define (display-narinfo-data narinfo) | |
9d2f48df | 261 | "Write to the current output port the contents of NARINFO in the format |
ef8f910f LC |
262 | expected by the daemon." |
263 | (format #t "~a\n~a\n~a\n" | |
264 | (narinfo-path narinfo) | |
265 | (or (and=> (narinfo-deriver narinfo) | |
266 | (cute string-append (%store-prefix) "/" <>)) | |
267 | "") | |
268 | (length (narinfo-references narinfo))) | |
269 | (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) | |
270 | (narinfo-references narinfo)) | |
b90ae065 | 271 | |
4736d06f | 272 | (let-values (((uri compression file-size) (narinfo-best-uri narinfo))) |
b90ae065 LC |
273 | (format #t "~a\n~a\n" |
274 | (or file-size 0) | |
275 | (or (narinfo-size narinfo) 0)))) | |
ef8f910f LC |
276 | |
277 | (define* (process-query command | |
55b2fc18 | 278 | #:key cache-urls acl) |
ef8f910f LC |
279 | "Reply to COMMAND, a query as written by the daemon to this process's |
280 | standard input. Use ACL as the access-control list against which to check | |
281 | authorized substitutes." | |
35e0c0cf CB |
282 | (define valid? |
283 | (if (%allow-unauthenticated-substitutes?) | |
284 | (begin | |
285 | (warn-about-missing-authentication) | |
ef8f910f | 286 | |
35e0c0cf CB |
287 | (const #t)) |
288 | (lambda (obj) | |
289 | (valid-narinfo? obj acl)))) | |
79c6614f | 290 | |
ef8f910f LC |
291 | (match (string-tokenize command) |
292 | (("have" paths ..1) | |
55b2fc18 | 293 | ;; Return the subset of PATHS available in CACHE-URLS. |
187e9709 CB |
294 | (let ((substitutable (lookup-narinfos/diverse |
295 | cache-urls paths valid? | |
20c08a8a | 296 | #:open-connection open-connection-for-uri/cached))) |
ef8f910f LC |
297 | (for-each (lambda (narinfo) |
298 | (format #t "~a~%" (narinfo-path narinfo))) | |
a9468b42 | 299 | substitutable) |
ef8f910f LC |
300 | (newline))) |
301 | (("info" paths ..1) | |
55b2fc18 | 302 | ;; Reply info about PATHS if it's in CACHE-URLS. |
187e9709 CB |
303 | (let ((substitutable (lookup-narinfos/diverse |
304 | cache-urls paths valid? | |
20c08a8a | 305 | #:open-connection open-connection-for-uri/cached))) |
a9468b42 | 306 | (for-each display-narinfo-data substitutable) |
ef8f910f LC |
307 | (newline))) |
308 | (wtf | |
309 | (error "unknown `--query' command" wtf)))) | |
310 | ||
5ff52145 LC |
311 | (define %max-cached-connections |
312 | ;; Maximum number of connections kept in cache by | |
313 | ;; 'open-connection-for-uri/cached'. | |
314 | 16) | |
315 | ||
316 | (define open-connection-for-uri/cached | |
317 | (let ((cache '())) | |
20c08a8a | 318 | (lambda* (uri #:key fresh? (timeout %fetch-timeout) verify-certificate?) |
5ff52145 | 319 | "Return a connection for URI, possibly reusing a cached connection. |
be5a75eb LC |
320 | When FRESH? is true, delete any cached connections for URI and open a new one. |
321 | Return #f if URI's scheme is 'file' or #f. | |
322 | ||
323 | When true, TIMEOUT is the maximum number of milliseconds to wait for | |
324 | connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS | |
325 | server certificates." | |
5ff52145 LC |
326 | (define host (uri-host uri)) |
327 | (define scheme (uri-scheme uri)) | |
328 | (define key (list host scheme (uri-port uri))) | |
329 | ||
330 | (and (not (memq scheme '(file #f))) | |
331 | (match (assoc-ref cache key) | |
332 | (#f | |
333 | ;; Open a new connection to URI and evict old entries from | |
334 | ;; CACHE, if any. | |
335 | (let-values (((socket) | |
336 | (guix:open-connection-for-uri | |
be5a75eb LC |
337 | uri |
338 | #:verify-certificate? verify-certificate? | |
339 | #:timeout timeout)) | |
5ff52145 LC |
340 | ((new-cache evicted) |
341 | (at-most (- %max-cached-connections 1) cache))) | |
342 | (for-each (match-lambda | |
343 | ((_ . port) | |
344 | (false-if-exception (close-port port)))) | |
345 | evicted) | |
346 | (set! cache (alist-cons key socket new-cache)) | |
347 | socket)) | |
348 | (socket | |
349 | (if (or fresh? (port-closed? socket)) | |
350 | (begin | |
351 | (false-if-exception (close-port socket)) | |
352 | (set! cache (alist-delete key cache)) | |
be5a75eb LC |
353 | (open-connection-for-uri/cached uri #:timeout timeout |
354 | #:verify-certificate? | |
355 | verify-certificate?)) | |
5ff52145 LC |
356 | (begin |
357 | ;; Drain input left from the previous use. | |
358 | (drain-input socket) | |
359 | socket)))))))) | |
360 | ||
ef8f910f | 361 | (define* (process-substitution store-item destination |
c7c7f068 LC |
362 | #:key cache-urls acl |
363 | deduplicate? print-build-trace?) | |
55b2fc18 | 364 | "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to |
9dfa20a2 | 365 | DESTINATION as a nar file. Verify the substitute against ACL, and verify its |
c7c7f068 LC |
366 | hash against what appears in the narinfo. When DEDUPLICATE? is true, and if |
367 | DESTINATION is in the store, deduplicate its files. Print a status line on | |
368 | the current output port." | |
b90ae065 LC |
369 | (define narinfo |
370 | (lookup-narinfo cache-urls store-item | |
35e0c0cf CB |
371 | (if (%allow-unauthenticated-substitutes?) |
372 | (const #t) | |
373 | (cut valid-narinfo? <> acl)))) | |
b90ae065 | 374 | |
c7c7f068 LC |
375 | (define destination-in-store? |
376 | (string-prefix? (string-append (%store-prefix) "/") | |
377 | destination)) | |
378 | ||
379 | (define (dump-file/deduplicate* . args) | |
380 | ;; Make sure deduplication looks at the right store (necessary in test | |
381 | ;; environments). | |
382 | (apply dump-file/deduplicate | |
383 | (append args (list #:store (%store-prefix))))) | |
384 | ||
8116cc66 CB |
385 | (define (fetch uri) |
386 | (case (uri-scheme uri) | |
387 | ((file) | |
388 | (let ((port (open-file (uri-path uri) "r0b"))) | |
389 | (values port (stat:size (stat port))))) | |
390 | ((http https) | |
391 | (guard (c ((http-get-error? c) | |
392 | (leave (G_ "download from '~a' failed: ~a, ~s~%") | |
393 | (uri->string (http-get-error-uri c)) | |
394 | (http-get-error-code c) | |
395 | (http-get-error-reason c)))) | |
396 | ;; Test this with: | |
397 | ;; sudo tc qdisc add dev eth0 root netem delay 1500ms | |
398 | ;; and then cancel with: | |
399 | ;; sudo tc qdisc del dev eth0 root | |
400 | (with-timeout %fetch-timeout | |
401 | (begin | |
402 | (warning (G_ "while fetching ~a: server is somewhat slow~%") | |
403 | (uri->string uri)) | |
404 | (warning (G_ "try `--no-substitutes' if the problem persists~%"))) | |
20c08a8a CB |
405 | (call-with-connection-error-handling |
406 | uri | |
407 | (lambda () | |
408 | (http-fetch uri #:text? #f | |
409 | #:open-connection open-connection-for-uri/cached | |
410 | #:keep-alive? #t | |
411 | #:buffered? #f | |
412 | #:verify-certificate? #f)))))) | |
8116cc66 CB |
413 | (else |
414 | (leave (G_ "unsupported substitute URI scheme: ~a~%") | |
415 | (uri->string uri))))) | |
416 | ||
b90ae065 LC |
417 | (unless narinfo |
418 | (leave (G_ "no valid substitute for '~a'~%") | |
419 | store-item)) | |
ef8f910f | 420 | |
b90ae065 | 421 | (let-values (((uri compression file-size) |
4736d06f | 422 | (narinfo-best-uri narinfo))) |
dc0f74e5 LC |
423 | (unless print-build-trace? |
424 | (format (current-error-port) | |
425 | (G_ "Downloading ~a...~%") (uri->string uri))) | |
426 | ||
ef8f910f | 427 | (let*-values (((raw download-size) |
5ff52145 LC |
428 | ;; 'guix publish' without '--cache' doesn't specify a |
429 | ;; Content-Length, so DOWNLOAD-SIZE is #f in this case. | |
b9d058e3 | 430 | (fetch uri)) |
ef8f910f | 431 | ((progress) |
b90ae065 LC |
432 | (let* ((dl-size (or download-size |
433 | (and (equal? compression "none") | |
ef8f910f | 434 | (narinfo-size narinfo)))) |
dc0f74e5 LC |
435 | (reporter (if print-build-trace? |
436 | (progress-reporter/trace | |
437 | destination | |
438 | (uri->string uri) dl-size | |
439 | (current-error-port)) | |
440 | (progress-reporter/file | |
441 | (uri->string uri) dl-size | |
442 | (current-error-port) | |
443 | #:abbreviation nar-uri-abbreviation)))) | |
5ff52145 LC |
444 | ;; Keep RAW open upon completion so we can later reuse |
445 | ;; the underlying connection. | |
446 | (progress-report-port reporter raw #:close? #f))) | |
ef8f910f | 447 | ((input pids) |
5efa0e4d SB |
448 | ;; NOTE: This 'progress' port of current process will be |
449 | ;; closed here, while the child process doing the | |
450 | ;; reporting will close it upon exit. | |
b90ae065 | 451 | (decompressed-port (string->symbol compression) |
9dfa20a2 LC |
452 | progress)) |
453 | ||
454 | ;; Compute the actual nar hash as we read it. | |
455 | ((algorithm expected) | |
456 | (narinfo-hash-algorithm+value narinfo)) | |
457 | ((hashed get-hash) | |
458 | (open-hash-input-port algorithm input))) | |
ef8f910f | 459 | ;; Unpack the Nar at INPUT into DESTINATION. |
c7c7f068 LC |
460 | (restore-file hashed destination |
461 | #:dump-file (if (and destination-in-store? | |
462 | deduplicate?) | |
463 | dump-file/deduplicate* | |
464 | dump-file)) | |
9dfa20a2 | 465 | (close-port hashed) |
4220514b | 466 | (close-port input) |
5efa0e4d SB |
467 | |
468 | ;; Wait for the reporter to finish. | |
469 | (every (compose zero? cdr waitpid) pids) | |
ef8f910f | 470 | |
79864851 SB |
471 | ;; Skip a line after what 'progress-reporter/file' printed, and another |
472 | ;; one to visually separate substitutions. | |
711df9ef LC |
473 | (display "\n\n" (current-error-port)) |
474 | ||
9dfa20a2 LC |
475 | ;; Check whether we got the data announced in NARINFO. |
476 | (let ((actual (get-hash))) | |
477 | (if (bytevector=? actual expected) | |
478 | ;; Tell the daemon that we're done. | |
479 | (format (current-output-port) "success ~a ~a~%" | |
480 | (narinfo-hash narinfo) (narinfo-size narinfo)) | |
481 | ;; The actual data has a different hash than that in NARINFO. | |
482 | (format (current-output-port) "hash-mismatch ~a ~a ~a~%" | |
483 | (hash-algorithm-name algorithm) | |
484 | (bytevector->nix-base32-string expected) | |
485 | (bytevector->nix-base32-string actual))))))) | |
ef8f910f LC |
486 | |
487 | \f | |
f65cf81a LC |
488 | ;;; |
489 | ;;; Entry point. | |
490 | ;;; | |
491 | ||
cdea30e0 LC |
492 | (define (check-acl-initialized) |
493 | "Warn if the ACL is uninitialized." | |
494 | (define (singleton? acl) | |
495 | ;; True if ACL contains just the user's public key. | |
496 | (and (file-exists? %public-key-file) | |
497 | (let ((key (call-with-input-file %public-key-file | |
498 | (compose string->canonical-sexp | |
2535635f | 499 | read-string)))) |
00fe9333 LC |
500 | (match acl |
501 | ((thing) | |
502 | (equal? (canonical-sexp->string thing) | |
503 | (canonical-sexp->string key))) | |
504 | (_ | |
505 | #f))))) | |
506 | ||
507 | (let ((acl (acl->public-keys (current-acl)))) | |
cdea30e0 | 508 | (when (or (null? acl) (singleton? acl)) |
69daee23 | 509 | (warning (G_ "ACL for archive imports seems to be uninitialized, \ |
cdea30e0 LC |
510 | substitutes may be unavailable\n"))))) |
511 | ||
9176607e LC |
512 | (define (daemon-options) |
513 | "Return a list of name/value pairs denoting build daemon options." | |
514 | (define %not-newline | |
515 | (char-set-complement (char-set #\newline))) | |
516 | ||
517 | (match (getenv "_NIX_OPTIONS") | |
518 | (#f ;should not happen when called by the daemon | |
519 | '()) | |
520 | (newline-separated | |
521 | ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n". | |
522 | (filter-map (lambda (option=value) | |
523 | (match (string-index option=value #\=) | |
524 | (#f ;invalid option setting | |
525 | #f) | |
526 | (equal-sign | |
527 | (cons (string-take option=value equal-sign) | |
528 | (string-drop option=value (+ 1 equal-sign)))))) | |
529 | (string-tokenize newline-separated %not-newline))))) | |
530 | ||
531 | (define (find-daemon-option option) | |
532 | "Return the value of build daemon option OPTION, or #f if it could not be | |
533 | found." | |
534 | (assoc-ref (daemon-options) option)) | |
535 | ||
218f6ecc | 536 | (define %default-substitute-urls |
71e2065a LC |
537 | (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client |
538 | (find-daemon-option "substitute-urls")) ;admin | |
4938b0ee | 539 | string-tokenize) |
55b2fc18 LC |
540 | ((urls ...) |
541 | urls) | |
4938b0ee LC |
542 | (#f |
543 | ;; This can only happen when this script is not invoked by the | |
544 | ;; daemon. | |
757e633d | 545 | '("http://ci.guix.gnu.org")))) |
9176607e | 546 | |
79f9dee3 MO |
547 | ;; In order to prevent using large number of discovered local substitute |
548 | ;; servers, limit the local substitute urls list size. | |
549 | (define %max-substitute-urls 50) | |
550 | ||
551 | (define* (randomize-substitute-urls urls | |
552 | #:key | |
553 | (max %max-substitute-urls)) | |
554 | "Return a list containing MAX urls from URLS, picked randomly. If URLS list | |
555 | is shorter than MAX elements, then it is directly returned." | |
556 | (define (random-item list) | |
557 | (list-ref list (random (length list)))) | |
558 | ||
559 | (if (<= (length urls) max) | |
560 | urls | |
561 | (let loop ((res '()) | |
562 | (urls urls)) | |
563 | (if (eq? (length res) max) | |
564 | res | |
565 | (let ((url (random-item urls))) | |
566 | (loop (cons url res) (delete url urls))))))) | |
567 | ||
568 | (define %local-substitute-urls | |
569 | ;; If the following option is passed to the daemon, use the substitutes list | |
570 | ;; provided by "guix discover" process. | |
79fd9f40 MO |
571 | (let* ((option (find-daemon-option "discover")) |
572 | (discover? (and option (string=? option "yes")))) | |
573 | (if discover? | |
574 | (randomize-substitute-urls (read-substitute-urls)) | |
575 | '()))) | |
79f9dee3 | 576 | |
218f6ecc LC |
577 | (define substitute-urls |
578 | ;; List of substitute URLs. | |
79f9dee3 MO |
579 | (make-parameter (append %local-substitute-urls |
580 | %default-substitute-urls))) | |
218f6ecc | 581 | |
b0a6a971 LC |
582 | (define (client-terminal-columns) |
583 | "Return the number of columns in the client's terminal, if it is known, or a | |
584 | default value." | |
585 | (or (and=> (or (find-daemon-option "untrusted-terminal-columns") | |
586 | (find-daemon-option "terminal-columns")) | |
85fc958d LC |
587 | (lambda (str) |
588 | (let ((number (string->number str))) | |
589 | (and number (max 20 (- number 1)))))) | |
b0a6a971 LC |
590 | 80)) |
591 | ||
8a210507 LC |
592 | (define (validate-uri uri) |
593 | (unless (string->uri uri) | |
69daee23 | 594 | (leave (G_ "~a: invalid URI~%") uri))) |
8a210507 | 595 | |
711df9ef LC |
596 | (define %error-to-file-descriptor-4? |
597 | ;; Whether to direct 'current-error-port' to file descriptor 4 like | |
598 | ;; 'guix-daemon' expects. | |
599 | (make-parameter #t)) | |
600 | ||
ee3226e9 LC |
601 | ;; The daemon's agent code opens file descriptor 4 for us and this is where |
602 | ;; stderr should go. | |
603 | (define-syntax-rule (with-redirected-error-port exp ...) | |
604 | "Evaluate EXP... with the current error port redirected to file descriptor 4 | |
605 | if needed, as expected by the daemon's agent." | |
606 | (let ((thunk (lambda () exp ...))) | |
607 | (if (%error-to-file-descriptor-4?) | |
608 | (parameterize ((current-error-port (fdopen 4 "wl"))) | |
609 | ;; Redirect diagnostics to file descriptor 4 as well. | |
610 | (guix-warning-port (current-error-port)) | |
611 | ||
612 | ;; 'with-continuation-barrier' captures the initial value of | |
613 | ;; 'current-error-port' to report backtraces in case of uncaught | |
614 | ;; exceptions. Without it, backtraces would be printed to FD 2, | |
615 | ;; thereby confusing the daemon. | |
616 | (with-continuation-barrier thunk)) | |
617 | (thunk)))) | |
618 | ||
3794ce93 LC |
619 | (define-command (guix-substitute . args) |
620 | (category internal) | |
621 | (synopsis "implement the build daemon's substituter protocol") | |
622 | ||
dc0f74e5 LC |
623 | (define print-build-trace? |
624 | (match (or (find-daemon-option "untrusted-print-extended-build-trace") | |
625 | (find-daemon-option "print-extended-build-trace")) | |
626 | (#f #f) | |
627 | ((= string->number number) (> number 0)) | |
628 | (_ #f))) | |
629 | ||
c7c7f068 LC |
630 | (define deduplicate? |
631 | (find-daemon-option "deduplicate")) | |
632 | ||
ee3226e9 | 633 | (with-redirected-error-port |
79c6614f LC |
634 | (mkdir-p %narinfo-cache-directory) |
635 | (maybe-remove-expired-cache-entries %narinfo-cache-directory | |
636 | cached-narinfo-files | |
637 | #:entry-expiration | |
638 | cached-narinfo-expiration-time | |
639 | #:cleanup-period | |
640 | %narinfo-expired-cache-entry-removal-delay) | |
641 | (check-acl-initialized) | |
642 | ||
643 | ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error | |
644 | ;; message. | |
645 | (for-each validate-uri (substitute-urls)) | |
646 | ||
647 | ;; Attempt to install the client's locale so that messages are suitably | |
648 | ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default | |
649 | ;; so don't change it. | |
650 | (match (or (find-daemon-option "untrusted-locale") | |
651 | (find-daemon-option "locale")) | |
652 | (#f #f) | |
653 | (locale (false-if-exception (setlocale LC_MESSAGES locale)))) | |
654 | ||
655 | (catch 'system-error | |
656 | (lambda () | |
657 | (set-thread-name "guix substitute")) | |
658 | (const #t)) ;GNU/Hurd lacks 'prctl' | |
659 | ||
660 | (with-networking | |
661 | (with-error-handling ; for signature errors | |
662 | (match args | |
663 | (("--query") | |
664 | (let ((acl (current-acl))) | |
665 | (let loop ((command (read-line))) | |
666 | (or (eof-object? command) | |
667 | (begin | |
668 | (process-query command | |
669 | #:cache-urls (substitute-urls) | |
670 | #:acl acl) | |
671 | (loop (read-line))))))) | |
711df9ef | 672 | (("--substitute") |
79c6614f LC |
673 | ;; Download STORE-PATH and store it as a Nar in file DESTINATION. |
674 | ;; Specify the number of columns of the terminal so the progress | |
675 | ;; report displays nicely. | |
676 | (parameterize ((current-terminal-columns (client-terminal-columns))) | |
711df9ef LC |
677 | (let loop () |
678 | (match (read-line) | |
679 | ((? eof-object?) | |
680 | #t) | |
681 | ((= string-tokenize ("substitute" store-path destination)) | |
682 | (process-substitution store-path destination | |
683 | #:cache-urls (substitute-urls) | |
684 | #:acl (current-acl) | |
c7c7f068 | 685 | #:deduplicate? deduplicate? |
711df9ef LC |
686 | #:print-build-trace? |
687 | print-build-trace?) | |
688 | (loop)))))) | |
79c6614f LC |
689 | ((or ("-V") ("--version")) |
690 | (show-version-and-exit "guix substitute")) | |
691 | (("--help") | |
692 | (show-help)) | |
693 | (opts | |
694 | (leave (G_ "~a: unrecognized options~%") opts))))))) | |
f65cf81a | 695 | |
bb7dcaea | 696 | ;;; Local Variables: |
2207f731 | 697 | ;;; eval: (put 'with-timeout 'scheme-indent-function 1) |
ee3226e9 | 698 | ;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0) |
ae3b6bb0 LC |
699 | ;;; End: |
700 | ||
2c74fde0 | 701 | ;;; substitute.scm ends here |