Commit | Line | Data |
---|---|---|
f65cf81a | 1 | ;;; GNU Guix --- Functional package management for GNU |
4fd06a4d | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
e9c6c584 | 3 | ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
f65cf81a LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
2c74fde0 | 20 | (define-module (guix scripts substitute) |
f65cf81a | 21 | #:use-module (guix ui) |
b879b3e8 | 22 | #:use-module ((guix store) #:hide (close-connection)) |
f65cf81a | 23 | #:use-module (guix utils) |
958dd3ce | 24 | #:use-module (guix combinators) |
fe0cff14 | 25 | #:use-module (guix config) |
c0cd1b3e | 26 | #:use-module (guix records) |
2535635f | 27 | #:use-module ((guix serialization) #:select (restore-file)) |
e9c6c584 | 28 | #:use-module (guix hash) |
895d1eda | 29 | #:use-module (guix base32) |
e9c6c584 | 30 | #:use-module (guix base64) |
2ea2aac6 | 31 | #:use-module (guix cache) |
e9c6c584 NK |
32 | #:use-module (guix pk-crypto) |
33 | #:use-module (guix pki) | |
d3a65203 | 34 | #:use-module ((guix build utils) #:select (mkdir-p dump-port)) |
a85060ef | 35 | #:use-module ((guix build download) |
b0a6a971 | 36 | #:select (current-terminal-columns |
cf5e5829 | 37 | progress-proc uri-abbreviation nar-uri-abbreviation |
4fd06a4d LC |
38 | (open-connection-for-uri |
39 | . guix:open-connection-for-uri) | |
b879b3e8 | 40 | close-connection |
a8be7b9a | 41 | store-path-abbreviation byte-count->string)) |
f65cf81a LC |
42 | #:use-module (ice-9 rdelim) |
43 | #:use-module (ice-9 regex) | |
44 | #:use-module (ice-9 match) | |
fe0cff14 | 45 | #:use-module (ice-9 format) |
4c7cacf1 | 46 | #:use-module (ice-9 ftw) |
a85060ef | 47 | #:use-module (ice-9 binary-ports) |
e9c6c584 | 48 | #:use-module (rnrs bytevectors) |
f65cf81a LC |
49 | #:use-module (srfi srfi-1) |
50 | #:use-module (srfi srfi-9) | |
51 | #:use-module (srfi srfi-11) | |
eba783b7 | 52 | #:use-module (srfi srfi-19) |
f65cf81a | 53 | #:use-module (srfi srfi-26) |
706e9e57 | 54 | #:use-module (srfi srfi-34) |
e9c6c584 | 55 | #:use-module (srfi srfi-35) |
f65cf81a | 56 | #:use-module (web uri) |
9b7bd1b1 | 57 | #:use-module (web http) |
d3a65203 LC |
58 | #:use-module (web request) |
59 | #:use-module (web response) | |
3b8258c5 | 60 | #:use-module (guix http-client) |
e9c6c584 | 61 | #:export (narinfo-signature->canonical-sexp |
ea0c6e05 LC |
62 | |
63 | narinfo? | |
64 | narinfo-path | |
65 | narinfo-uri | |
66 | narinfo-uri-base | |
67 | narinfo-compression | |
68 | narinfo-file-hash | |
69 | narinfo-file-size | |
70 | narinfo-hash | |
71 | narinfo-size | |
72 | narinfo-references | |
73 | narinfo-deriver | |
74 | narinfo-system | |
75 | narinfo-signature | |
76 | ||
77 | narinfo-hash->sha256 | |
78 | assert-valid-narinfo | |
79 | ||
80 | lookup-narinfos | |
55b2fc18 | 81 | lookup-narinfos/diverse |
e9c6c584 NK |
82 | read-narinfo |
83 | write-narinfo | |
2c74fde0 | 84 | guix-substitute)) |
f65cf81a LC |
85 | |
86 | ;;; Comment: | |
87 | ;;; | |
88 | ;;; This is the "binary substituter". It is invoked by the daemon do check | |
89 | ;;; for the existence of available "substitutes" (pre-built binaries), and to | |
90 | ;;; actually use them as a substitute to building things locally. | |
91 | ;;; | |
92 | ;;; If possible, substitute a binary for the requested store path, using a Nix | |
93 | ;;; "binary cache". This program implements the Nix "substituter" protocol. | |
94 | ;;; | |
95 | ;;; Code: | |
96 | ||
eba783b7 | 97 | (define %narinfo-cache-directory |
f10dcbf1 LC |
98 | ;; A local cache of narinfos, to avoid going to the network. Most of the |
99 | ;; time, 'guix substitute' is called by guix-daemon as root and stores its | |
100 | ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' | |
101 | ;; as a user, it stores its cache in ~/.cache. | |
102 | (if (zero? (getuid)) | |
103 | (or (and=> (getenv "XDG_CACHE_HOME") | |
104 | (cut string-append <> "/guix/substitute")) | |
105 | (string-append %state-directory "/substitute/cache")) | |
106 | (string-append (cache-directory) "/substitute"))) | |
eba783b7 | 107 | |
e9c6c584 NK |
108 | (define %allow-unauthenticated-substitutes? |
109 | ;; Whether to allow unchecked substitutes. This is useful for testing | |
110 | ;; purposes, and should be avoided otherwise. | |
111 | (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") | |
112 | (cut string-ci=? <> "yes")) | |
113 | (begin | |
69daee23 | 114 | (warning (G_ "authentication and authorization of substitutes \ |
e9c6c584 NK |
115 | disabled!~%")) |
116 | #t))) | |
117 | ||
eba783b7 LC |
118 | (define %narinfo-ttl |
119 | ;; Number of seconds during which cached narinfo lookups are considered | |
23d60ba6 LC |
120 | ;; valid for substitute servers that do not advertise a TTL via the |
121 | ;; 'Cache-Control' response header. | |
5e6039a4 | 122 | (* 36 3600)) |
eba783b7 LC |
123 | |
124 | (define %narinfo-negative-ttl | |
958fb14c | 125 | ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). |
eba783b7 LC |
126 | (* 3 3600)) |
127 | ||
958fb14c LC |
128 | (define %narinfo-transient-error-ttl |
129 | ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). | |
130 | (* 10 60)) | |
131 | ||
4c7cacf1 LC |
132 | (define %narinfo-expired-cache-entry-removal-delay |
133 | ;; How often we want to remove files corresponding to expired cache entries. | |
134 | (* 7 24 3600)) | |
135 | ||
ce689ccf LC |
136 | (define fields->alist |
137 | ;; The narinfo format is really just like recutils. | |
138 | recutils->alist) | |
f65cf81a | 139 | |
2207f731 LC |
140 | (define %fetch-timeout |
141 | ;; Number of seconds after which networking is considered "slow". | |
8b79e2e6 | 142 | 5) |
2207f731 | 143 | |
bb7dcaea LC |
144 | (define %random-state |
145 | (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) | |
146 | ||
2207f731 LC |
147 | (define-syntax-rule (with-timeout duration handler body ...) |
148 | "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY | |
149 | again." | |
150 | (begin | |
151 | (sigaction SIGALRM | |
152 | (lambda (signum) | |
153 | (sigaction SIGALRM SIG_DFL) | |
154 | handler)) | |
155 | (alarm duration) | |
156 | (call-with-values | |
157 | (lambda () | |
158 | (let try () | |
159 | (catch 'system-error | |
160 | (lambda () | |
161 | body ...) | |
162 | (lambda args | |
c509bf8c LC |
163 | ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR |
164 | ;; because of the bug at | |
bb7dcaea LC |
165 | ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>. |
166 | ;; When that happens, try again. Note: SA_RESTART cannot be | |
167 | ;; used because of <http://bugs.gnu.org/14640>. | |
2207f731 | 168 | (if (= EINTR (system-error-errno args)) |
bb7dcaea LC |
169 | (begin |
170 | ;; Wait a little to avoid bursts. | |
171 | (usleep (random 3000000 %random-state)) | |
172 | (try)) | |
2207f731 LC |
173 | (apply throw args)))))) |
174 | (lambda result | |
175 | (alarm 0) | |
176 | (sigaction SIGALRM SIG_DFL) | |
177 | (apply values result))))) | |
178 | ||
cc27dbcf | 179 | (define* (fetch uri #:key (buffered? #t) (timeout? #t)) |
fe0cff14 | 180 | "Return a binary input port to URI and the number of bytes it's expected to |
cc27dbcf | 181 | provide." |
f65cf81a LC |
182 | (case (uri-scheme uri) |
183 | ((file) | |
b6952cad LC |
184 | (let ((port (open-file (uri-path uri) |
185 | (if buffered? "rb" "r0b")))) | |
fe0cff14 | 186 | (values port (stat:size (stat port))))) |
9b7bd1b1 | 187 | ((http https) |
706e9e57 | 188 | (guard (c ((http-get-error? c) |
69daee23 | 189 | (leave (G_ "download from '~a' failed: ~a, ~s~%") |
cc27dbcf LC |
190 | (uri->string (http-get-error-uri c)) |
191 | (http-get-error-code c) | |
192 | (http-get-error-reason c)))) | |
706e9e57 LC |
193 | ;; Test this with: |
194 | ;; sudo tc qdisc add dev eth0 root netem delay 1500ms | |
195 | ;; and then cancel with: | |
196 | ;; sudo tc qdisc del dev eth0 root | |
197 | (let ((port #f)) | |
09d809db | 198 | (with-timeout (if timeout? |
706e9e57 LC |
199 | %fetch-timeout |
200 | 0) | |
201 | (begin | |
69daee23 | 202 | (warning (G_ "while fetching ~a: server is somewhat slow~%") |
706e9e57 | 203 | (uri->string uri)) |
69daee23 | 204 | (warning (G_ "try `--no-substitutes' if the problem persists~%")) |
706e9e57 LC |
205 | |
206 | ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, | |
207 | ;; and thus PORT had to be closed and re-opened. This is not the | |
208 | ;; case afterward. | |
209 | (unless (or (guile-version>? "2.0.9") | |
210 | (version>? (version) "2.0.9.39")) | |
211 | (when port | |
b879b3e8 | 212 | (close-connection port)))) |
706e9e57 LC |
213 | (begin |
214 | (when (or (not port) (port-closed? port)) | |
4fd06a4d LC |
215 | (set! port (guix:open-connection-for-uri |
216 | uri #:verify-certificate? #f)) | |
9b7bd1b1 | 217 | (unless (or buffered? (not (file-port? port))) |
76238483 | 218 | (setvbuf port _IONBF))) |
166ba5b1 LC |
219 | (http-fetch uri #:text? #f #:port port |
220 | #:verify-certificate? #f)))))) | |
204d34ff | 221 | (else |
69daee23 | 222 | (leave (G_ "unsupported substitute URI scheme: ~a~%") |
204d34ff | 223 | (uri->string uri))))) |
f65cf81a | 224 | |
074efd63 LC |
225 | (define-record-type <cache-info> |
226 | (%make-cache-info url store-directory wants-mass-query?) | |
227 | cache-info? | |
228 | (url cache-info-url) | |
229 | (store-directory cache-info-store-directory) | |
230 | (wants-mass-query? cache-info-wants-mass-query?)) | |
231 | ||
232 | (define (download-cache-info url) | |
026ca50f LC |
233 | "Download the information for the cache at URL. On success, return a |
234 | <cache-info> object and a port on which to send further HTTP requests. On | |
235 | failure, return #f and #f." | |
236 | (define uri | |
237 | (string->uri (string-append url "/nix-cache-info"))) | |
238 | ||
239 | (define (read-cache-info port) | |
240 | (alist->record (fields->alist port) | |
241 | (cut %make-cache-info url <...>) | |
242 | '("StoreDir" "WantMassQuery"))) | |
243 | ||
244 | (catch #t | |
245 | (lambda () | |
246 | (case (uri-scheme uri) | |
247 | ((file) | |
248 | (values (call-with-input-file (uri-path uri) | |
249 | read-cache-info) | |
250 | #f)) | |
251 | ((http https) | |
4fd06a4d LC |
252 | (let ((port (guix:open-connection-for-uri |
253 | uri | |
254 | #:verify-certificate? #f | |
255 | #:timeout %fetch-timeout))) | |
026ca50f | 256 | (guard (c ((http-get-error? c) |
69daee23 | 257 | (warning (G_ "while fetching '~a': ~a (~s)~%") |
026ca50f LC |
258 | (uri->string (http-get-error-uri c)) |
259 | (http-get-error-code c) | |
260 | (http-get-error-reason c)) | |
b879b3e8 | 261 | (close-connection port) |
69daee23 | 262 | (warning (G_ "ignoring substitute server at '~s'~%") url) |
026ca50f LC |
263 | (values #f #f))) |
264 | (values (read-cache-info (http-fetch uri | |
166ba5b1 | 265 | #:verify-certificate? #f |
026ca50f LC |
266 | #:port port |
267 | #:keep-alive? #t)) | |
268 | port)))))) | |
269 | (lambda (key . args) | |
270 | (case key | |
271 | ((getaddrinfo-error system-error) | |
272 | ;; Silently ignore the error: probably due to lack of network access. | |
273 | (values #f #f)) | |
274 | (else | |
275 | (apply throw key args)))))) | |
f65cf81a | 276 | |
074efd63 | 277 | \f |
f65cf81a | 278 | (define-record-type <narinfo> |
00230df1 | 279 | (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size |
e9c6c584 | 280 | references deriver system signature contents) |
f65cf81a LC |
281 | narinfo? |
282 | (path narinfo-path) | |
fe0cff14 | 283 | (uri narinfo-uri) |
00230df1 | 284 | (uri-base narinfo-uri-base) ; URI of the cache it originates from |
f65cf81a LC |
285 | (compression narinfo-compression) |
286 | (file-hash narinfo-file-hash) | |
287 | (file-size narinfo-file-size) | |
288 | (nar-hash narinfo-hash) | |
289 | (nar-size narinfo-size) | |
290 | (references narinfo-references) | |
291 | (deriver narinfo-deriver) | |
e9c6c584 NK |
292 | (system narinfo-system) |
293 | (signature narinfo-signature) ; canonical sexp | |
294 | ;; The original contents of a narinfo file. This field is needed because we | |
295 | ;; want to preserve the exact textual representation for verification purposes. | |
296 | ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> | |
297 | ;; for more information. | |
298 | (contents narinfo-contents)) | |
299 | ||
ea0c6e05 LC |
300 | (define (narinfo-hash->sha256 hash) |
301 | "If the string HASH denotes a sha256 hash, return it as a bytevector. | |
302 | Otherwise return #f." | |
303 | (and (string-prefix? "sha256:" hash) | |
304 | (nix-base32-string->bytevector (string-drop hash 7)))) | |
305 | ||
e9c6c584 NK |
306 | (define (narinfo-signature->canonical-sexp str) |
307 | "Return the value of a narinfo's 'Signature' field as a canonical sexp." | |
308 | (match (string-split str #\;) | |
e465d9e1 | 309 | ((version host-name sig) |
e9c6c584 NK |
310 | (let ((maybe-number (string->number version))) |
311 | (cond ((not (number? maybe-number)) | |
69daee23 | 312 | (leave (G_ "signature version must be a number: ~s~%") |
e9c6c584 NK |
313 | version)) |
314 | ;; Currently, there are no other versions. | |
315 | ((not (= 1 maybe-number)) | |
69daee23 | 316 | (leave (G_ "unsupported signature version: ~a~%") |
e9c6c584 | 317 | maybe-number)) |
cdea30e0 LC |
318 | (else |
319 | (let ((signature (utf8->string (base64-decode sig)))) | |
320 | (catch 'gcry-error | |
321 | (lambda () | |
322 | (string->canonical-sexp signature)) | |
6ef3644e | 323 | (lambda (key proc err) |
69daee23 | 324 | (leave (G_ "signature is not a valid \ |
e4687a5e LC |
325 | s-expression: ~s~%") |
326 | signature)))))))) | |
e9c6c584 | 327 | (x |
69daee23 | 328 | (leave (G_ "invalid format of the signature field: ~a~%") x)))) |
f65cf81a | 329 | |
e9c6c584 NK |
330 | (define (narinfo-maker str cache-url) |
331 | "Return a narinfo constructor for narinfos originating from CACHE-URL. STR | |
332 | must contain the original contents of a narinfo file." | |
fe0cff14 | 333 | (lambda (path url compression file-hash file-size nar-hash nar-size |
e9c6c584 | 334 | references deriver system signature) |
fe0cff14 LC |
335 | "Return a new <narinfo> object." |
336 | (%make-narinfo path | |
fe0cff14 LC |
337 | ;; Handle the case where URL is a relative URL. |
338 | (or (string->uri url) | |
339 | (string->uri (string-append cache-url "/" url))) | |
00230df1 | 340 | cache-url |
fe0cff14 LC |
341 | |
342 | compression file-hash | |
343 | (and=> file-size string->number) | |
344 | nar-hash | |
345 | (and=> nar-size string->number) | |
346 | (string-tokenize references) | |
347 | (match deriver | |
348 | ((or #f "") #f) | |
349 | (_ deriver)) | |
e9c6c584 | 350 | system |
cdea30e0 LC |
351 | (false-if-exception |
352 | (and=> signature narinfo-signature->canonical-sexp)) | |
e9c6c584 | 353 | str))) |
f65cf81a | 354 | |
e4687a5e | 355 | (define* (assert-valid-signature narinfo signature hash |
e9c6c584 | 356 | #:optional (acl (current-acl))) |
e4687a5e LC |
357 | "Bail out if SIGNATURE, a canonical sexp representing the signature of |
358 | NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." | |
359 | (let ((uri (uri->string (narinfo-uri narinfo)))) | |
360 | (signature-case (signature hash acl) | |
361 | (valid-signature #t) | |
362 | (invalid-signature | |
69daee23 | 363 | (leave (G_ "invalid signature for '~a'~%") uri)) |
e4687a5e | 364 | (hash-mismatch |
69daee23 | 365 | (leave (G_ "hash mismatch for '~a'~%") uri)) |
e4687a5e | 366 | (unauthorized-key |
69daee23 | 367 | (leave (G_ "'~a' is signed with an unauthorized key~%") uri)) |
e4687a5e | 368 | (corrupt-signature |
69daee23 | 369 | (leave (G_ "signature on '~a' is corrupt~%") uri))))) |
e9c6c584 | 370 | |
0561e9ae LC |
371 | (define* (read-narinfo port #:optional url |
372 | #:key size) | |
e9c6c584 | 373 | "Read a narinfo from PORT. If URL is true, it must be a string used to |
0561e9ae LC |
374 | build full URIs from relative URIs found while reading PORT. When SIZE is |
375 | true, read at most SIZE bytes from PORT; otherwise, read as much as possible. | |
cdea30e0 LC |
376 | |
377 | No authentication and authorization checks are performed here!" | |
0561e9ae LC |
378 | (let ((str (utf8->string (if size |
379 | (get-bytevector-n port size) | |
380 | (get-bytevector-all port))))) | |
cdea30e0 LC |
381 | (alist->record (call-with-input-string str fields->alist) |
382 | (narinfo-maker str url) | |
383 | '("StorePath" "URL" "Compression" | |
384 | "FileHash" "FileSize" "NarHash" "NarSize" | |
385 | "References" "Deriver" "System" | |
386 | "Signature")))) | |
387 | ||
e4687a5e LC |
388 | (define (narinfo-sha256 narinfo) |
389 | "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a | |
390 | 'Signature' field." | |
391 | (let ((contents (narinfo-contents narinfo))) | |
8234fcf2 | 392 | (match (string-contains contents "Signature:") |
e4687a5e | 393 | (#f #f) |
8234fcf2 LC |
394 | (index |
395 | (let ((above-signature (string-take contents index))) | |
396 | (sha256 (string->utf8 above-signature))))))) | |
e4687a5e | 397 | |
8146fdb3 LC |
398 | (define* (assert-valid-narinfo narinfo |
399 | #:optional (acl (current-acl)) | |
7c515a43 | 400 | #:key verbose?) |
cdea30e0 LC |
401 | "Raise an exception if NARINFO lacks a signature, has an invalid signature, |
402 | or is signed by an unauthorized key." | |
e4687a5e LC |
403 | (let ((hash (narinfo-sha256 narinfo))) |
404 | (if (not hash) | |
cdea30e0 LC |
405 | (if %allow-unauthenticated-substitutes? |
406 | narinfo | |
69daee23 | 407 | (leave (G_ "substitute at '~a' lacks a signature~%") |
e4687a5e LC |
408 | (uri->string (narinfo-uri narinfo)))) |
409 | (let ((signature (narinfo-signature narinfo))) | |
cdea30e0 | 410 | (unless %allow-unauthenticated-substitutes? |
e4687a5e | 411 | (assert-valid-signature narinfo signature hash acl) |
8146fdb3 LC |
412 | (when verbose? |
413 | (format (current-error-port) | |
69daee23 | 414 | (G_ "Found valid signature for ~a~%") |
f954c9b5 LC |
415 | (narinfo-path narinfo)) |
416 | (format (current-error-port) | |
69daee23 | 417 | (G_ "From ~a~%") |
8146fdb3 | 418 | (uri->string (narinfo-uri narinfo))))) |
cdea30e0 LC |
419 | narinfo)))) |
420 | ||
e4687a5e | 421 | (define* (valid-narinfo? narinfo #:optional (acl (current-acl))) |
cdea30e0 | 422 | "Return #t if NARINFO's signature is not valid." |
e4687a5e LC |
423 | (or %allow-unauthenticated-substitutes? |
424 | (let ((hash (narinfo-sha256 narinfo)) | |
425 | (signature (narinfo-signature narinfo))) | |
426 | (and hash signature | |
427 | (signature-case (signature hash acl) | |
428 | (valid-signature #t) | |
429 | (else #f)))))) | |
eba783b7 LC |
430 | |
431 | (define (write-narinfo narinfo port) | |
432 | "Write NARINFO to PORT." | |
e9c6c584 | 433 | (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) |
eba783b7 LC |
434 | |
435 | (define (narinfo->string narinfo) | |
436 | "Return the external representation of NARINFO." | |
437 | (call-with-output-string (cut write-narinfo narinfo <>))) | |
438 | ||
00230df1 | 439 | (define (string->narinfo str cache-uri) |
cdea30e0 LC |
440 | "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of |
441 | the cache STR originates form." | |
00230df1 | 442 | (call-with-input-string str (cut read-narinfo <> cache-uri))) |
eba783b7 | 443 | |
895d1eda LC |
444 | (define (narinfo-cache-file cache-url path) |
445 | "Return the name of the local file that contains an entry for PATH. The | |
446 | entry is stored in a sub-directory specific to CACHE-URL." | |
30d4bc04 LC |
447 | ;; The daemon does not sanitize its input, so PATH could be something like |
448 | ;; "/gnu/store/foo". Gracefully handle that. | |
449 | (match (store-path-hash-part path) | |
450 | (#f | |
69daee23 | 451 | (leave (G_ "'~a' does not name a store item~%") path)) |
30d4bc04 LC |
452 | ((? string? hash-part) |
453 | (string-append %narinfo-cache-directory "/" | |
454 | (bytevector->base32-string (sha256 (string->utf8 cache-url))) | |
455 | "/" hash-part)))) | |
895d1eda LC |
456 | |
457 | (define (cached-narinfo cache-url path) | |
458 | "Check locally if we have valid info about PATH coming from CACHE-URL. | |
459 | Return two values: a Boolean indicating whether we have valid cached info, and | |
460 | that info, which may be either #f (when PATH is unavailable) or the narinfo | |
461 | for PATH." | |
eba783b7 LC |
462 | (define now |
463 | (current-time time-monotonic)) | |
464 | ||
eba783b7 | 465 | (define cache-file |
895d1eda | 466 | (narinfo-cache-file cache-url path)) |
d3a65203 LC |
467 | |
468 | (catch 'system-error | |
469 | (lambda () | |
470 | (call-with-input-file cache-file | |
471 | (lambda (p) | |
472 | (match (read p) | |
1cf7e318 | 473 | (('narinfo ('version 2) |
d3a65203 | 474 | ('cache-uri cache-uri) |
1cf7e318 | 475 | ('date date) ('ttl _) ('value #f)) |
d3a65203 LC |
476 | ;; A cached negative lookup. |
477 | (if (obsolete? date now %narinfo-negative-ttl) | |
478 | (values #f #f) | |
479 | (values #t #f))) | |
1cf7e318 | 480 | (('narinfo ('version 2) |
d3a65203 | 481 | ('cache-uri cache-uri) |
1cf7e318 | 482 | ('date date) ('ttl ttl) ('value value)) |
d3a65203 | 483 | ;; A cached positive lookup |
1cf7e318 | 484 | (if (obsolete? date now ttl) |
d3a65203 LC |
485 | (values #f #f) |
486 | (values #t (string->narinfo value cache-uri)))) | |
487 | (('narinfo ('version v) _ ...) | |
488 | (values #f #f)))))) | |
489 | (lambda _ | |
490 | (values #f #f)))) | |
491 | ||
23d60ba6 LC |
492 | (define (cache-narinfo! cache-url path narinfo ttl) |
493 | "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the | |
494 | given TTL (a number of seconds or #f). NARINFO may be #f, in which case it | |
495 | indicates that PATH is unavailable at CACHE-URL." | |
d3a65203 LC |
496 | (define now |
497 | (current-time time-monotonic)) | |
eba783b7 | 498 | |
cdea30e0 | 499 | (define (cache-entry cache-uri narinfo) |
1cf7e318 | 500 | `(narinfo (version 2) |
cdea30e0 | 501 | (cache-uri ,cache-uri) |
eba783b7 | 502 | (date ,(time-second now)) |
23d60ba6 LC |
503 | (ttl ,(or ttl |
504 | (if narinfo %narinfo-ttl %narinfo-negative-ttl))) | |
eba783b7 LC |
505 | (value ,(and=> narinfo narinfo->string)))) |
506 | ||
895d1eda | 507 | (let ((file (narinfo-cache-file cache-url path))) |
f10dcbf1 LC |
508 | (mkdir-p (dirname file)) |
509 | (with-atomic-file-output file | |
510 | (lambda (out) | |
511 | (write (cache-entry cache-url narinfo) out)))) | |
895d1eda | 512 | |
d3a65203 LC |
513 | narinfo) |
514 | ||
515 | (define (narinfo-request cache-url path) | |
516 | "Return an HTTP request for the narinfo of PATH at CACHE-URL." | |
517 | (let ((url (string-append cache-url "/" (store-path-hash-part path) | |
f264e838 TGR |
518 | ".narinfo")) |
519 | (headers '((User-Agent . "GNU Guile")))) | |
520 | (build-request (string->uri url) #:method 'GET #:headers headers))) | |
d3a65203 | 521 | |
026ca50f | 522 | (define* (http-multiple-get base-uri proc seed requests |
166ba5b1 | 523 | #:key port (verify-certificate? #t)) |
9b7bd1b1 | 524 | "Send all of REQUESTS to the server at BASE-URI. Call PROC for each |
f151298f LC |
525 | response, passing it the request object, the response, a port from which to |
526 | read the response body, and the previous result, starting with SEED, à la | |
026ca50f LC |
527 | 'fold'. Return the final result. When PORT is specified, use it as the |
528 | initial connection on which HTTP requests are sent." | |
529 | (let connect ((port port) | |
530 | (requests requests) | |
f151298f | 531 | (result seed)) |
d3a65203 LC |
532 | ;; (format (current-error-port) "connecting (~a requests left)..." |
533 | ;; (length requests)) | |
4fd06a4d LC |
534 | (let ((p (or port (guix:open-connection-for-uri |
535 | base-uri | |
536 | #:verify-certificate? | |
537 | verify-certificate?)))) | |
9b7bd1b1 LC |
538 | ;; For HTTPS, P is not a file port and does not support 'setvbuf'. |
539 | (when (file-port? p) | |
540 | (setvbuf p _IOFBF (expt 2 16))) | |
541 | ||
d3a65203 | 542 | ;; Send all of REQUESTS in a row. |
ec278439 LC |
543 | ;; XXX: Do our own caching to work around inefficiencies when |
544 | ;; communicating over TLS: <http://bugs.gnu.org/22966>. | |
545 | (let-values (((buffer get) (open-bytevector-output-port))) | |
546 | ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. | |
547 | (when (module-variable (resolve-interface '(web http)) | |
548 | 'http-proxy-port?) | |
549 | (set-http-proxy-port?! buffer (http-proxy-port? p))) | |
550 | ||
551 | (for-each (cut write-request <> buffer) requests) | |
552 | (put-bytevector p (get)) | |
553 | (force-output p)) | |
d3a65203 LC |
554 | |
555 | ;; Now start processing responses. | |
556 | (let loop ((requests requests) | |
557 | (result result)) | |
558 | (match requests | |
559 | (() | |
560 | (reverse result)) | |
561 | ((head tail ...) | |
075d99f1 AP |
562 | (let* ((resp (read-response p)) |
563 | (body (response-body-port resp)) | |
f151298f | 564 | (result (proc head resp body result))) |
d3a65203 LC |
565 | ;; The server can choose to stop responding at any time, in which |
566 | ;; case we have to try again. Check whether that is the case. | |
075d99f1 | 567 | ;; Note that even upon "Connection: close", we can read from BODY. |
d3a65203 LC |
568 | (match (assq 'connection (response-headers resp)) |
569 | (('connection 'close) | |
b879b3e8 | 570 | (close-connection p) |
026ca50f | 571 | (connect #f tail result)) ;try again |
d3a65203 | 572 | (_ |
075d99f1 | 573 | (loop tail result)))))))))) ;keep going |
d3a65203 LC |
574 | |
575 | (define (read-to-eof port) | |
576 | "Read from PORT until EOF is reached. The data are discarded." | |
577 | (dump-port port (%make-void-port "w"))) | |
578 | ||
579 | (define (narinfo-from-file file url) | |
580 | "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f | |
581 | if file doesn't exist, and the narinfo otherwise." | |
582 | (catch 'system-error | |
583 | (lambda () | |
584 | (call-with-input-file file | |
585 | (cut read-narinfo <> url))) | |
586 | (lambda args | |
587 | (if (= ENOENT (system-error-errno args)) | |
588 | #f | |
589 | (apply throw args))))) | |
590 | ||
074efd63 LC |
591 | (define (fetch-narinfos url paths) |
592 | "Retrieve all the narinfos for PATHS from the cache at URL and return them." | |
d3a65203 LC |
593 | (define update-progress! |
594 | (let ((done 0)) | |
595 | (lambda () | |
596 | (display #\cr (current-error-port)) | |
597 | (force-output (current-error-port)) | |
598 | (format (current-error-port) | |
69daee23 | 599 | (G_ "updating list of substitutes from '~a'... ~5,1f%") |
d3a65203 LC |
600 | url (* 100. (/ done (length paths)))) |
601 | (set! done (+ 1 done))))) | |
602 | ||
f151298f | 603 | (define (handle-narinfo-response request response port result) |
958fb14c LC |
604 | (let* ((code (response-code response)) |
605 | (len (response-content-length response)) | |
23d60ba6 LC |
606 | (cache (response-cache-control response)) |
607 | (ttl (and cache (assoc-ref cache 'max-age)))) | |
d3a65203 LC |
608 | ;; Make sure to read no more than LEN bytes since subsequent bytes may |
609 | ;; belong to the next response. | |
958fb14c LC |
610 | (if (= code 200) ; hit |
611 | (let ((narinfo (read-narinfo port url #:size len))) | |
612 | (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) | |
613 | (update-progress!) | |
614 | (cons narinfo result)) | |
615 | (let* ((path (uri-path (request-uri request))) | |
a7a3b390 LC |
616 | (hash-part (basename |
617 | (string-drop-right path 8)))) ;drop ".narinfo" | |
958fb14c LC |
618 | (if len |
619 | (get-bytevector-n port len) | |
620 | (read-to-eof port)) | |
621 | (cache-narinfo! url | |
622 | (find (cut string-contains <> hash-part) paths) | |
623 | #f | |
624 | (if (= 404 code) | |
625 | ttl | |
626 | %narinfo-transient-error-ttl)) | |
627 | (update-progress!) | |
628 | result)))) | |
d3a65203 | 629 | |
026ca50f | 630 | (define (do-fetch uri port) |
ae4427e3 | 631 | (case (and=> uri uri-scheme) |
9b7bd1b1 | 632 | ((http https) |
ae4427e3 LC |
633 | (let ((requests (map (cut narinfo-request url <>) paths))) |
634 | (update-progress!) | |
166ba5b1 LC |
635 | |
636 | ;; Note: Do not check HTTPS server certificates to avoid depending on | |
637 | ;; the X.509 PKI. We can do it because we authenticate narinfos, | |
638 | ;; which provides a much stronger guarantee. | |
9b7bd1b1 | 639 | (let ((result (http-multiple-get uri |
ae4427e3 | 640 | handle-narinfo-response '() |
026ca50f | 641 | requests |
166ba5b1 | 642 | #:verify-certificate? #f |
026ca50f | 643 | #:port port))) |
b879b3e8 | 644 | (close-connection port) |
ae4427e3 LC |
645 | (newline (current-error-port)) |
646 | result))) | |
647 | ((file #f) | |
648 | (let* ((base (string-append (uri-path uri) "/")) | |
649 | (files (map (compose (cut string-append base <> ".narinfo") | |
650 | store-path-hash-part) | |
651 | paths))) | |
652 | (filter-map (cut narinfo-from-file <> url) files))) | |
653 | (else | |
69daee23 | 654 | (leave (G_ "~s: unsupported server URI scheme~%") |
ae4427e3 LC |
655 | (if uri (uri-scheme uri) url))))) |
656 | ||
026ca50f LC |
657 | (let-values (((cache-info port) |
658 | (download-cache-info url))) | |
659 | (and cache-info | |
660 | (if (string=? (cache-info-store-directory cache-info) | |
661 | (%store-prefix)) | |
662 | (do-fetch (string->uri url) port) ;reuse PORT | |
663 | (begin | |
69daee23 | 664 | (warning (G_ "'~a' uses different store '~a'; ignoring it~%") |
026ca50f | 665 | url (cache-info-store-directory cache-info)) |
b879b3e8 | 666 | (close-connection port) |
026ca50f | 667 | #f))))) |
d3a65203 LC |
668 | |
669 | (define (lookup-narinfos cache paths) | |
670 | "Return the narinfos for PATHS, invoking the server at CACHE when no | |
671 | information is available locally." | |
672 | (let-values (((cached missing) | |
673 | (fold2 (lambda (path cached missing) | |
674 | (let-values (((valid? value) | |
895d1eda | 675 | (cached-narinfo cache path))) |
d3a65203 | 676 | (if valid? |
a89dde1e LC |
677 | (if value |
678 | (values (cons value cached) missing) | |
679 | (values cached missing)) | |
d3a65203 LC |
680 | (values cached (cons path missing))))) |
681 | '() | |
682 | '() | |
683 | paths))) | |
684 | (if (null? missing) | |
685 | cached | |
074efd63 LC |
686 | (let ((missing (fetch-narinfos cache missing))) |
687 | (append cached (or missing '())))))) | |
d3a65203 | 688 | |
55b2fc18 LC |
689 | (define (lookup-narinfos/diverse caches paths) |
690 | "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. | |
691 | That is, when a cache lacks a narinfo, look it up in the next cache, and so | |
692 | on. Return a list of narinfos for PATHS or a subset thereof." | |
693 | (let loop ((caches caches) | |
694 | (paths paths) | |
695 | (result '())) | |
696 | (match paths | |
697 | (() ;we're done | |
698 | result) | |
699 | (_ | |
700 | (match caches | |
701 | ((cache rest ...) | |
702 | (let* ((narinfos (lookup-narinfos cache paths)) | |
703 | (hits (map narinfo-path narinfos)) | |
704 | (missing (lset-difference string=? paths hits))) ;XXX: perf | |
705 | (loop rest missing (append narinfos result)))) | |
706 | (() ;that's it | |
707 | result)))))) | |
708 | ||
709 | (define (lookup-narinfo caches path) | |
710 | "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH | |
711 | was found." | |
712 | (match (lookup-narinfos/diverse caches (list path)) | |
713 | ((answer) answer) | |
714 | (_ #f))) | |
f65cf81a | 715 | |
2ea2aac6 LC |
716 | (define (cached-narinfo-expiration-time file) |
717 | "Return the expiration time for FILE, which is a cached narinfo." | |
718 | (catch 'system-error | |
719 | (lambda () | |
720 | (call-with-input-file file | |
721 | (lambda (port) | |
722 | (match (read port) | |
723 | (('narinfo ('version 2) ('cache-uri uri) | |
724 | ('date date) ('ttl ttl) ('value #f)) | |
725 | (+ date %narinfo-negative-ttl)) | |
726 | (('narinfo ('version 2) ('cache-uri uri) | |
727 | ('date date) ('ttl ttl) ('value value)) | |
728 | (+ date ttl)) | |
729 | (x | |
730 | 0))))) | |
731 | (lambda args | |
732 | ;; FILE may have been deleted. | |
733 | 0))) | |
4c7cacf1 | 734 | |
2ea2aac6 | 735 | (define (narinfo-cache-directories directory) |
895d1eda | 736 | "Return the list of narinfo cache directories (one per cache URL.)" |
2ea2aac6 | 737 | (map (cut string-append directory "/" <>) |
895d1eda LC |
738 | (scandir %narinfo-cache-directory |
739 | (lambda (item) | |
740 | (and (not (member item '("." ".."))) | |
741 | (file-is-directory? | |
742 | (string-append %narinfo-cache-directory | |
743 | "/" item))))))) | |
744 | ||
2ea2aac6 LC |
745 | (define* (cached-narinfo-files #:optional |
746 | (directory %narinfo-cache-directory)) | |
747 | "Return the list of cached narinfo files under DIRECTORY." | |
748 | (append-map (lambda (directory) | |
749 | (map (cut string-append directory "/" <>) | |
750 | (scandir directory | |
751 | (lambda (file) | |
752 | (= (string-length file) 32))))) | |
753 | (narinfo-cache-directories directory))) | |
4c7cacf1 | 754 | |
a85060ef LC |
755 | (define (progress-report-port report-progress port) |
756 | "Return a port that calls REPORT-PROGRESS every time something is read from | |
757 | PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by | |
758 | `progress-proc'." | |
759 | (define total 0) | |
760 | (define (read! bv start count) | |
761 | (let ((n (match (get-bytevector-n! port bv start count) | |
762 | ((? eof-object?) 0) | |
763 | (x x)))) | |
764 | (set! total (+ total n)) | |
765 | (report-progress total (const n)) | |
766 | ;; XXX: We're not in control, so we always return anyway. | |
767 | n)) | |
768 | ||
09d809db LC |
769 | (make-custom-binary-input-port "progress-port-proc" |
770 | read! #f #f | |
b879b3e8 | 771 | (cut close-connection port))) |
a85060ef | 772 | |
cf5d2ca3 LC |
773 | (define-syntax with-networking |
774 | (syntax-rules () | |
8c321299 | 775 | "Catch DNS lookup errors and TLS errors and gracefully exit." |
cf5d2ca3 LC |
776 | ;; Note: no attempt is made to catch other networking errors, because DNS |
777 | ;; lookup errors are typically the first one, and because other errors are | |
778 | ;; a subset of `system-error', which is harder to filter. | |
779 | ((_ exp ...) | |
8c321299 | 780 | (catch #t |
cf5d2ca3 | 781 | (lambda () exp ...) |
8c321299 LC |
782 | (match-lambda* |
783 | (('getaddrinfo-error error) | |
69daee23 | 784 | (leave (G_ "host name lookup error: ~a~%") |
8c321299 LC |
785 | (gai-strerror error))) |
786 | (('gnutls-error error proc . rest) | |
787 | (let ((error->string (module-ref (resolve-interface '(gnutls)) | |
788 | 'error->string))) | |
69daee23 | 789 | (leave (G_ "TLS error in procedure '~a': ~a~%") |
8c321299 LC |
790 | proc (error->string error)))) |
791 | (args | |
792 | (apply throw args))))))) | |
cf5d2ca3 | 793 | |
f65cf81a | 794 | \f |
29479de5 LC |
795 | ;;; |
796 | ;;; Help. | |
797 | ;;; | |
798 | ||
799 | (define (show-help) | |
69daee23 | 800 | (display (G_ "Usage: guix substitute [OPTION]... |
29479de5 | 801 | Internal tool to substitute a pre-built binary to a local build.\n")) |
69daee23 | 802 | (display (G_ " |
29479de5 LC |
803 | --query report on the availability of substitutes for the |
804 | store file names passed on the standard input")) | |
69daee23 | 805 | (display (G_ " |
29479de5 LC |
806 | --substitute STORE-FILE DESTINATION |
807 | download STORE-FILE and store it as a Nar in file | |
808 | DESTINATION")) | |
809 | (newline) | |
69daee23 | 810 | (display (G_ " |
29479de5 | 811 | -h, --help display this help and exit")) |
69daee23 | 812 | (display (G_ " |
29479de5 LC |
813 | -V, --version display version information and exit")) |
814 | (newline) | |
815 | (show-bug-report-information)) | |
816 | ||
817 | ||
818 | \f | |
ef8f910f LC |
819 | ;;; |
820 | ;;; Daemon/substituter protocol. | |
821 | ;;; | |
822 | ||
823 | (define (display-narinfo-data narinfo) | |
9d2f48df | 824 | "Write to the current output port the contents of NARINFO in the format |
ef8f910f LC |
825 | expected by the daemon." |
826 | (format #t "~a\n~a\n~a\n" | |
827 | (narinfo-path narinfo) | |
828 | (or (and=> (narinfo-deriver narinfo) | |
829 | (cute string-append (%store-prefix) "/" <>)) | |
830 | "") | |
831 | (length (narinfo-references narinfo))) | |
832 | (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) | |
833 | (narinfo-references narinfo)) | |
834 | (format #t "~a\n~a\n" | |
835 | (or (narinfo-file-size narinfo) 0) | |
836 | (or (narinfo-size narinfo) 0))) | |
837 | ||
838 | (define* (process-query command | |
55b2fc18 | 839 | #:key cache-urls acl) |
ef8f910f LC |
840 | "Reply to COMMAND, a query as written by the daemon to this process's |
841 | standard input. Use ACL as the access-control list against which to check | |
842 | authorized substitutes." | |
843 | (define (valid? obj) | |
55b2fc18 | 844 | (valid-narinfo? obj acl)) |
ef8f910f LC |
845 | |
846 | (match (string-tokenize command) | |
847 | (("have" paths ..1) | |
55b2fc18 LC |
848 | ;; Return the subset of PATHS available in CACHE-URLS. |
849 | (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) | |
ef8f910f LC |
850 | (for-each (lambda (narinfo) |
851 | (format #t "~a~%" (narinfo-path narinfo))) | |
852 | (filter valid? substitutable)) | |
853 | (newline))) | |
854 | (("info" paths ..1) | |
55b2fc18 LC |
855 | ;; Reply info about PATHS if it's in CACHE-URLS. |
856 | (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) | |
ef8f910f LC |
857 | (for-each display-narinfo-data (filter valid? substitutable)) |
858 | (newline))) | |
859 | (wtf | |
860 | (error "unknown `--query' command" wtf)))) | |
861 | ||
862 | (define* (process-substitution store-item destination | |
55b2fc18 LC |
863 | #:key cache-urls acl) |
864 | "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to | |
ef8f910f | 865 | DESTINATION as a nar file. Verify the substitute against ACL." |
55b2fc18 | 866 | (let* ((narinfo (lookup-narinfo cache-urls store-item)) |
ef8f910f LC |
867 | (uri (narinfo-uri narinfo))) |
868 | ;; Make sure it is signed and everything. | |
869 | (assert-valid-narinfo narinfo acl) | |
870 | ||
871 | ;; Tell the daemon what the expected hash of the Nar itself is. | |
872 | (format #t "~a~%" (narinfo-hash narinfo)) | |
873 | ||
ac0a7b0f LC |
874 | (format (current-error-port) |
875 | ;; TRANSLATORS: The second part of this message looks like | |
876 | ;; "(4.1MiB installed)"; it shows the size of the package once | |
877 | ;; installed. | |
69daee23 | 878 | (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%") |
7c515a43 | 879 | (uri->string uri) |
ef8f910f LC |
880 | ;; Use the Nar size as an estimate of the installed size. |
881 | (narinfo-size narinfo) | |
882 | (and=> (narinfo-size narinfo) | |
a8be7b9a | 883 | (cute byte-count->string <>))) |
ef8f910f LC |
884 | (let*-values (((raw download-size) |
885 | ;; Note that Hydra currently generates Nars on the fly | |
886 | ;; and doesn't specify a Content-Length, so | |
887 | ;; DOWNLOAD-SIZE is #f in practice. | |
888 | (fetch uri #:buffered? #f #:timeout? #f)) | |
889 | ((progress) | |
890 | (let* ((comp (narinfo-compression narinfo)) | |
891 | (dl-size (or download-size | |
892 | (and (equal? comp "none") | |
893 | (narinfo-size narinfo)))) | |
cf5e5829 | 894 | (progress (progress-proc (uri->string uri) |
ef8f910f | 895 | dl-size |
a8be7b9a SS |
896 | (current-error-port) |
897 | #:abbreviation | |
cf5e5829 | 898 | nar-uri-abbreviation))) |
ef8f910f LC |
899 | (progress-report-port progress raw))) |
900 | ((input pids) | |
901 | (decompressed-port (and=> (narinfo-compression narinfo) | |
902 | string->symbol) | |
903 | progress))) | |
904 | ;; Unpack the Nar at INPUT into DESTINATION. | |
905 | (restore-file input destination) | |
906 | ||
7c515a43 LC |
907 | ;; Skip a line after what 'progress-proc' printed, and another one to |
908 | ;; visually separate substitutions. | |
909 | (display "\n\n" (current-error-port)) | |
ef8f910f LC |
910 | |
911 | (every (compose zero? cdr waitpid) pids)))) | |
912 | ||
913 | \f | |
f65cf81a LC |
914 | ;;; |
915 | ;;; Entry point. | |
916 | ;;; | |
917 | ||
cdea30e0 LC |
918 | (define (check-acl-initialized) |
919 | "Warn if the ACL is uninitialized." | |
920 | (define (singleton? acl) | |
921 | ;; True if ACL contains just the user's public key. | |
922 | (and (file-exists? %public-key-file) | |
923 | (let ((key (call-with-input-file %public-key-file | |
924 | (compose string->canonical-sexp | |
2535635f | 925 | read-string)))) |
00fe9333 LC |
926 | (match acl |
927 | ((thing) | |
928 | (equal? (canonical-sexp->string thing) | |
929 | (canonical-sexp->string key))) | |
930 | (_ | |
931 | #f))))) | |
932 | ||
933 | (let ((acl (acl->public-keys (current-acl)))) | |
cdea30e0 | 934 | (when (or (null? acl) (singleton? acl)) |
69daee23 | 935 | (warning (G_ "ACL for archive imports seems to be uninitialized, \ |
cdea30e0 LC |
936 | substitutes may be unavailable\n"))))) |
937 | ||
9176607e LC |
938 | (define (daemon-options) |
939 | "Return a list of name/value pairs denoting build daemon options." | |
940 | (define %not-newline | |
941 | (char-set-complement (char-set #\newline))) | |
942 | ||
943 | (match (getenv "_NIX_OPTIONS") | |
944 | (#f ;should not happen when called by the daemon | |
945 | '()) | |
946 | (newline-separated | |
947 | ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n". | |
948 | (filter-map (lambda (option=value) | |
949 | (match (string-index option=value #\=) | |
950 | (#f ;invalid option setting | |
951 | #f) | |
952 | (equal-sign | |
953 | (cons (string-take option=value equal-sign) | |
954 | (string-drop option=value (+ 1 equal-sign)))))) | |
955 | (string-tokenize newline-separated %not-newline))))) | |
956 | ||
957 | (define (find-daemon-option option) | |
958 | "Return the value of build daemon option OPTION, or #f if it could not be | |
959 | found." | |
960 | (assoc-ref (daemon-options) option)) | |
961 | ||
55b2fc18 | 962 | (define %cache-urls |
71e2065a LC |
963 | (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client |
964 | (find-daemon-option "substitute-urls")) ;admin | |
4938b0ee | 965 | string-tokenize) |
55b2fc18 LC |
966 | ((urls ...) |
967 | urls) | |
4938b0ee LC |
968 | (#f |
969 | ;; This can only happen when this script is not invoked by the | |
970 | ;; daemon. | |
55b2fc18 | 971 | '("http://hydra.gnu.org")))) |
9176607e | 972 | |
b0a6a971 LC |
973 | (define (client-terminal-columns) |
974 | "Return the number of columns in the client's terminal, if it is known, or a | |
975 | default value." | |
976 | (or (and=> (or (find-daemon-option "untrusted-terminal-columns") | |
977 | (find-daemon-option "terminal-columns")) | |
85fc958d LC |
978 | (lambda (str) |
979 | (let ((number (string->number str))) | |
980 | (and number (max 20 (- number 1)))))) | |
b0a6a971 LC |
981 | 80)) |
982 | ||
8a210507 LC |
983 | (define (validate-uri uri) |
984 | (unless (string->uri uri) | |
69daee23 | 985 | (leave (G_ "~a: invalid URI~%") uri))) |
8a210507 | 986 | |
2c74fde0 | 987 | (define (guix-substitute . args) |
f65cf81a | 988 | "Implement the build daemon's substituter protocol." |
eba783b7 | 989 | (mkdir-p %narinfo-cache-directory) |
2ea2aac6 LC |
990 | (maybe-remove-expired-cache-entries %narinfo-cache-directory |
991 | cached-narinfo-files | |
992 | #:entry-expiration | |
993 | cached-narinfo-expiration-time | |
994 | #:cleanup-period | |
995 | %narinfo-expired-cache-entry-removal-delay) | |
00fe9333 | 996 | (check-acl-initialized) |
d43eb499 LC |
997 | |
998 | ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly | |
999 | ;; when we know we cannot substitute, but we must emit a newline on stdout | |
1000 | ;; when everything is alright. | |
55b2fc18 LC |
1001 | (when (null? %cache-urls) |
1002 | (exit 0)) | |
d43eb499 LC |
1003 | |
1004 | ;; Say hello (see above.) | |
1005 | (newline) | |
1006 | (force-output (current-output-port)) | |
1007 | ||
8a210507 LC |
1008 | ;; Sanity-check %CACHE-URLS so we can provide a meaningful error message. |
1009 | (for-each validate-uri %cache-urls) | |
1010 | ||
38f50f49 LC |
1011 | ;; Attempt to install the client's locale, mostly so that messages are |
1012 | ;; suitably translated. | |
1013 | (match (or (find-daemon-option "untrusted-locale") | |
1014 | (find-daemon-option "locale")) | |
1015 | (#f #f) | |
1016 | (locale (false-if-exception (setlocale LC_ALL locale)))) | |
1017 | ||
cf5d2ca3 | 1018 | (with-networking |
cdea30e0 LC |
1019 | (with-error-handling ; for signature errors |
1020 | (match args | |
1021 | (("--query") | |
ef8f910f | 1022 | (let ((acl (current-acl))) |
cdea30e0 LC |
1023 | (let loop ((command (read-line))) |
1024 | (or (eof-object? command) | |
1025 | (begin | |
ef8f910f | 1026 | (process-query command |
55b2fc18 | 1027 | #:cache-urls %cache-urls |
ef8f910f | 1028 | #:acl acl) |
cdea30e0 LC |
1029 | (loop (read-line))))))) |
1030 | (("--substitute" store-path destination) | |
1031 | ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. | |
b0a6a971 LC |
1032 | ;; Specify the number of columns of the terminal so the progress |
1033 | ;; report displays nicely. | |
1034 | (parameterize ((current-terminal-columns (client-terminal-columns))) | |
1035 | (process-substitution store-path destination | |
1036 | #:cache-urls %cache-urls | |
1037 | #:acl (current-acl)))) | |
cdea30e0 | 1038 | (("--version") |
2c74fde0 | 1039 | (show-version-and-exit "guix substitute")) |
cdea30e0 LC |
1040 | (("--help") |
1041 | (show-help)) | |
1042 | (opts | |
69daee23 | 1043 | (leave (G_ "~a: unrecognized options~%") opts)))))) |
f65cf81a | 1044 | |
bb7dcaea | 1045 | ;;; Local Variables: |
2207f731 | 1046 | ;;; eval: (put 'with-timeout 'scheme-indent-function 1) |
ae3b6bb0 LC |
1047 | ;;; End: |
1048 | ||
2c74fde0 | 1049 | ;;; substitute.scm ends here |