| blob | 0baba9198126fc7ad9b2c83193607ebbd3ee762d |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
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/>.
20 (define-module (guix scripts substitute)
21 #:use-module (guix ui)
22 #:use-module (guix store)
23 #:use-module (guix utils)
24 #:use-module (guix config)
25 #:use-module (guix records)
26 #:use-module (guix serialization)
27 #:use-module (guix hash)
28 #:use-module (guix base64)
29 #:use-module (guix pk-crypto)
30 #:use-module (guix pki)
31 #:use-module ((guix build utils) #:select (mkdir-p dump-port))
32 #:use-module ((guix build download)
33 #:select (progress-proc uri-abbreviation))
34 #:use-module (ice-9 rdelim)
35 #:use-module (ice-9 regex)
36 #:use-module (ice-9 match)
37 #:use-module (ice-9 format)
38 #:use-module (ice-9 ftw)
39 #:use-module (ice-9 binary-ports)
40 #:use-module (rnrs io ports)
41 #:use-module (rnrs bytevectors)
42 #:use-module (srfi srfi-1)
43 #:use-module (srfi srfi-9)
44 #:use-module (srfi srfi-11)
45 #:use-module (srfi srfi-19)
46 #:use-module (srfi srfi-26)
47 #:use-module (srfi srfi-34)
48 #:use-module (srfi srfi-35)
49 #:use-module (web uri)
50 #:use-module (web request)
51 #:use-module (web response)
52 #:use-module (guix http-client)
53 #:export (narinfo-signature->canonical-sexp
54 read-narinfo
55 write-narinfo
56 guix-substitute))
58 ;;; Comment:
59 ;;;
60 ;;; This is the "binary substituter". It is invoked by the daemon do check
61 ;;; for the existence of available "substitutes" (pre-built binaries), and to
62 ;;; actually use them as a substitute to building things locally.
63 ;;;
64 ;;; If possible, substitute a binary for the requested store path, using a Nix
65 ;;; "binary cache". This program implements the Nix "substituter" protocol.
66 ;;;
67 ;;; Code:
69 (define %narinfo-cache-directory
70 ;; A local cache of narinfos, to avoid going to the network.
71 (or (and=> (getenv "XDG_CACHE_HOME")
72 (cut string-append <> "/guix/substitute"))
73 (string-append %state-directory "/substitute/cache")))
75 (define %allow-unauthenticated-substitutes?
76 ;; Whether to allow unchecked substitutes. This is useful for testing
77 ;; purposes, and should be avoided otherwise.
78 (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
79 (cut string-ci=? <> "yes"))
80 (begin
81 (warning (_ "authentication and authorization of substitutes \
82 disabled!~%"))
83 #t)))
85 (define %narinfo-ttl
86 ;; Number of seconds during which cached narinfo lookups are considered
87 ;; valid. This is a reasonable default value (corresponds to the TTL for
88 ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to
89 ;; state what their TTL is in /nix-cache-info. (XXX)
90 (* 36 3600))
92 (define %narinfo-negative-ttl
93 ;; Likewise, but for negative lookups---i.e., cached lookup failures.
94 (* 3 3600))
96 (define %narinfo-expired-cache-entry-removal-delay
97 ;; How often we want to remove files corresponding to expired cache entries.
98 (* 7 24 3600))
100 (define fields->alist
101 ;; The narinfo format is really just like recutils.
102 recutils->alist)
104 (define %fetch-timeout
105 ;; Number of seconds after which networking is considered "slow".
106 5)
108 (define %random-state
109 (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
111 (define-syntax-rule (with-timeout duration handler body ...)
112 "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
113 again."
114 (begin
115 (sigaction SIGALRM
116 (lambda (signum)
117 (sigaction SIGALRM SIG_DFL)
118 handler))
119 (alarm duration)
120 (call-with-values
121 (lambda ()
122 (let try ()
123 (catch 'system-error
124 (lambda ()
125 body ...)
126 (lambda args
127 ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
128 ;; because of the bug at
129 ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
130 ;; When that happens, try again. Note: SA_RESTART cannot be
131 ;; used because of <http://bugs.gnu.org/14640>.
132 (if (= EINTR (system-error-errno args))
133 (begin
134 ;; Wait a little to avoid bursts.
135 (usleep (random 3000000 %random-state))
136 (try))
137 (apply throw args))))))
138 (lambda result
139 (alarm 0)
140 (sigaction SIGALRM SIG_DFL)
141 (apply values result)))))
143 (define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f))
144 "Return a binary input port to URI and the number of bytes it's expected to
145 provide. If QUIET-404? is true, HTTP 404 error conditions are passed through
146 to the caller without emitting an error message."
147 (case (uri-scheme uri)
148 ((file)
149 (let ((port (open-file (uri-path uri)
150 (if buffered? "rb" "r0b"))))
151 (values port (stat:size (stat port)))))
152 ((http)
153 (guard (c ((http-get-error? c)
154 (let ((code (http-get-error-code c)))
155 (if (and (= code 404) quiet-404?)
156 (raise c)
157 (leave (_ "download from '~a' failed: ~a, ~s~%")
158 (uri->string (http-get-error-uri c))
159 code (http-get-error-reason c))))))
160 ;; Test this with:
161 ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
162 ;; and then cancel with:
163 ;; sudo tc qdisc del dev eth0 root
164 (let ((port #f))
165 (with-timeout (if timeout?
166 %fetch-timeout
167 0)
168 (begin
169 (warning (_ "while fetching ~a: server is somewhat slow~%")
170 (uri->string uri))
171 (warning (_ "try `--no-substitutes' if the problem persists~%"))
173 ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
174 ;; and thus PORT had to be closed and re-opened. This is not the
175 ;; case afterward.
176 (unless (or (guile-version>? "2.0.9")
177 (version>? (version) "2.0.9.39"))
178 (when port
179 (close-port port))))
180 (begin
181 (when (or (not port) (port-closed? port))
182 (set! port (open-socket-for-uri uri))
183 (unless buffered?
184 (setvbuf port _IONBF)))
185 (http-fetch uri #:text? #f #:port port))))))))
187 (define-record-type <cache>
188 (%make-cache url store-directory wants-mass-query?)
189 cache?
190 (url cache-url)
191 (store-directory cache-store-directory)
192 (wants-mass-query? cache-wants-mass-query?))
194 (define (open-cache url)
195 "Open the binary cache at URL. Return a <cache> object on success, or #f on
196 failure."
197 (define (download-cache-info url)
198 ;; Download the `nix-cache-info' from URL, and return its contents as an
199 ;; list of key/value pairs.
200 (and=> (false-if-exception (fetch (string->uri url)))
201 fields->alist))
203 (and=> (download-cache-info (string-append url "/nix-cache-info"))
204 (lambda (properties)
205 (alist->record properties
206 (cut %make-cache url <...>)
207 '("StoreDir" "WantMassQuery")))))
209 (define-syntax-rule (open-cache* url)
210 "Delayed variant of 'open-cache' that also lets the user know that they're
211 gonna have to wait."
212 (delay (begin
213 (format (current-error-port)
214 (_ "updating list of substitutes from '~a'...\r")
215 url)
216 (open-cache url))))
218 (define-record-type <narinfo>
219 (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
220 references deriver system signature contents)
221 narinfo?
222 (path narinfo-path)
223 (uri narinfo-uri)
224 (uri-base narinfo-uri-base) ; URI of the cache it originates from
225 (compression narinfo-compression)
226 (file-hash narinfo-file-hash)
227 (file-size narinfo-file-size)
228 (nar-hash narinfo-hash)
229 (nar-size narinfo-size)
230 (references narinfo-references)
231 (deriver narinfo-deriver)
232 (system narinfo-system)
233 (signature narinfo-signature) ; canonical sexp
234 ;; The original contents of a narinfo file. This field is needed because we
235 ;; want to preserve the exact textual representation for verification purposes.
236 ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
237 ;; for more information.
238 (contents narinfo-contents))
240 (define (narinfo-signature->canonical-sexp str)
241 "Return the value of a narinfo's 'Signature' field as a canonical sexp."
242 (match (string-split str #\;)
243 ((version _ sig)
244 (let ((maybe-number (string->number version)))
245 (cond ((not (number? maybe-number))
246 (leave (_ "signature version must be a number: ~s~%")
247 version))
248 ;; Currently, there are no other versions.
249 ((not (= 1 maybe-number))
250 (leave (_ "unsupported signature version: ~a~%")
251 maybe-number))
252 (else
253 (let ((signature (utf8->string (base64-decode sig))))
254 (catch 'gcry-error
255 (lambda ()
256 (string->canonical-sexp signature))
257 (lambda (key proc err)
258 (leave (_ "signature is not a valid \
259 s-expression: ~s~%")
260 signature))))))))
261 (x
262 (leave (_ "invalid format of the signature field: ~a~%") x))))
264 (define (narinfo-maker str cache-url)
265 "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
266 must contain the original contents of a narinfo file."
267 (lambda (path url compression file-hash file-size nar-hash nar-size
268 references deriver system signature)
269 "Return a new <narinfo> object."
270 (%make-narinfo path
271 ;; Handle the case where URL is a relative URL.
272 (or (string->uri url)
273 (string->uri (string-append cache-url "/" url)))
274 cache-url
276 compression file-hash
277 (and=> file-size string->number)
278 nar-hash
279 (and=> nar-size string->number)
280 (string-tokenize references)
281 (match deriver
282 ((or #f "") #f)
283 (_ deriver))
284 system
285 (false-if-exception
286 (and=> signature narinfo-signature->canonical-sexp))
287 str)))
289 (define* (assert-valid-signature narinfo signature hash
290 #:optional (acl (current-acl)))
291 "Bail out if SIGNATURE, a canonical sexp representing the signature of
292 NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
293 (let ((uri (uri->string (narinfo-uri narinfo))))
294 (signature-case (signature hash acl)
295 (valid-signature #t)
296 (invalid-signature
297 (leave (_ "invalid signature for '~a'~%") uri))
298 (hash-mismatch
299 (leave (_ "hash mismatch for '~a'~%") uri))
300 (unauthorized-key
301 (leave (_ "'~a' is signed with an unauthorized key~%") uri))
302 (corrupt-signature
303 (leave (_ "signature on '~a' is corrupt~%") uri)))))
305 (define* (read-narinfo port #:optional url
306 #:key size)
307 "Read a narinfo from PORT. If URL is true, it must be a string used to
308 build full URIs from relative URIs found while reading PORT. When SIZE is
309 true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
311 No authentication and authorization checks are performed here!"
312 (let ((str (utf8->string (if size
313 (get-bytevector-n port size)
314 (get-bytevector-all port)))))
315 (alist->record (call-with-input-string str fields->alist)
316 (narinfo-maker str url)
317 '("StorePath" "URL" "Compression"
318 "FileHash" "FileSize" "NarHash" "NarSize"
319 "References" "Deriver" "System"
320 "Signature"))))
322 (define (narinfo-sha256 narinfo)
323 "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
324 'Signature' field."
325 (let ((contents (narinfo-contents narinfo)))
326 (match (string-contains contents "Signature:")
327 (#f #f)
328 (index
329 (let ((above-signature (string-take contents index)))
330 (sha256 (string->utf8 above-signature)))))))
332 (define* (assert-valid-narinfo narinfo
333 #:optional (acl (current-acl))
334 #:key (verbose? #t))
335 "Raise an exception if NARINFO lacks a signature, has an invalid signature,
336 or is signed by an unauthorized key."
337 (let ((hash (narinfo-sha256 narinfo)))
338 (if (not hash)
339 (if %allow-unauthenticated-substitutes?
340 narinfo
341 (leave (_ "substitute at '~a' lacks a signature~%")
342 (uri->string (narinfo-uri narinfo))))
343 (let ((signature (narinfo-signature narinfo)))
344 (unless %allow-unauthenticated-substitutes?
345 (assert-valid-signature narinfo signature hash acl)
346 (when verbose?
347 (format (current-error-port)
348 "found valid signature for '~a', from '~a'~%"
349 (narinfo-path narinfo)
350 (uri->string (narinfo-uri narinfo)))))
351 narinfo))))
353 (define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
354 "Return #t if NARINFO's signature is not valid."
355 (or %allow-unauthenticated-substitutes?
356 (let ((hash (narinfo-sha256 narinfo))
357 (signature (narinfo-signature narinfo)))
358 (and hash signature
359 (signature-case (signature hash acl)
360 (valid-signature #t)
361 (else #f))))))
363 (define (write-narinfo narinfo port)
364 "Write NARINFO to PORT."
365 (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
367 (define (narinfo->string narinfo)
368 "Return the external representation of NARINFO."
369 (call-with-output-string (cut write-narinfo narinfo <>)))
371 (define (string->narinfo str cache-uri)
372 "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
373 the cache STR originates form."
374 (call-with-input-string str (cut read-narinfo <> cache-uri)))
376 (define (obsolete? date now ttl)
377 "Return #t if DATE is obsolete compared to NOW + TTL seconds."
378 (time>? (subtract-duration now (make-time time-duration 0 ttl))
379 (make-time time-monotonic 0 date)))
382 (define (narinfo-cache-file path)
383 "Return the name of the local file that contains an entry for PATH."
384 (string-append %narinfo-cache-directory "/"
385 (store-path-hash-part path)))
387 (define (cached-narinfo path)
388 "Check locally if we have valid info about PATH. Return two values: a
389 Boolean indicating whether we have valid cached info, and that info, which may
390 be either #f (when PATH is unavailable) or the narinfo for PATH."
391 (define now
392 (current-time time-monotonic))
394 (define cache-file
395 (narinfo-cache-file path))
397 (catch 'system-error
398 (lambda ()
399 (call-with-input-file cache-file
400 (lambda (p)
401 (match (read p)
402 (('narinfo ('version 1)
403 ('cache-uri cache-uri)
404 ('date date) ('value #f))
405 ;; A cached negative lookup.
406 (if (obsolete? date now %narinfo-negative-ttl)
407 (values #f #f)
408 (values #t #f)))
409 (('narinfo ('version 1)
410 ('cache-uri cache-uri)
411 ('date date) ('value value))
412 ;; A cached positive lookup
413 (if (obsolete? date now %narinfo-ttl)
414 (values #f #f)
415 (values #t (string->narinfo value cache-uri))))
416 (('narinfo ('version v) _ ...)
417 (values #f #f))))))
418 (lambda _
419 (values #f #f))))
421 (define (cache-narinfo! cache path narinfo)
422 "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may
423 be #f, in which case it indicates that PATH is unavailable at CACHE."
424 (define now
425 (current-time time-monotonic))
427 (define (cache-entry cache-uri narinfo)
428 `(narinfo (version 1)
429 (cache-uri ,cache-uri)
430 (date ,(time-second now))
431 (value ,(and=> narinfo narinfo->string))))
433 (with-atomic-file-output (narinfo-cache-file path)
434 (lambda (out)
435 (write (cache-entry (cache-url cache) narinfo) out)))
436 narinfo)
438 (define (narinfo-request cache-url path)
439 "Return an HTTP request for the narinfo of PATH at CACHE-URL."
440 (let ((url (string-append cache-url "/" (store-path-hash-part path)
441 ".narinfo")))
442 (build-request (string->uri url) #:method 'GET)))
444 (define (http-multiple-get base-url requests proc)
445 "Send all of REQUESTS to the server at BASE-URL. Call PROC for each
446 response, passing it the request object, the response, and a port from which
447 to read the response body. Return the list of results."
448 (let connect ((requests requests)
449 (result '()))
450 ;; (format (current-error-port) "connecting (~a requests left)..."
451 ;; (length requests))
452 (let ((p (open-socket-for-uri base-url)))
453 ;; Send all of REQUESTS in a row.
454 (setvbuf p _IOFBF (expt 2 16))
455 (for-each (cut write-request <> p) requests)
456 (force-output p)
458 ;; Now start processing responses.
459 (let loop ((requests requests)
460 (result result))
461 (match requests
462 (()
463 (reverse result))
464 ((head tail ...)
465 (let* ((resp (read-response p))
466 (body (response-body-port resp))
467 (result (cons (proc head resp body) result)))
468 ;; The server can choose to stop responding at any time, in which
469 ;; case we have to try again. Check whether that is the case.
470 ;; Note that even upon "Connection: close", we can read from BODY.
471 (match (assq 'connection (response-headers resp))
472 (('connection 'close)
473 (close-port p)
474 (connect tail result)) ;try again
475 (_
476 (loop tail result)))))))))) ;keep going
478 (define (read-to-eof port)
479 "Read from PORT until EOF is reached. The data are discarded."
480 (dump-port port (%make-void-port "w")))
482 (define (narinfo-from-file file url)
483 "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
484 if file doesn't exist, and the narinfo otherwise."
485 (catch 'system-error
486 (lambda ()
487 (call-with-input-file file
488 (cut read-narinfo <> url)))
489 (lambda args
490 (if (= ENOENT (system-error-errno args))
491 #f
492 (apply throw args)))))
494 (define (fetch-narinfos cache paths)
495 "Retrieve all the narinfos for PATHS from CACHE and return them."
496 (define url
497 (cache-url cache))
499 (define update-progress!
500 (let ((done 0))
501 (lambda ()
502 (display #\cr (current-error-port))
503 (force-output (current-error-port))
504 (format (current-error-port)
505 (_ "updating list of substitutes from '~a'... ~5,1f%")
506 url (* 100. (/ done (length paths))))
507 (set! done (+ 1 done)))))
509 (define (handle-narinfo-response request response port)
510 (let ((len (response-content-length response)))
511 ;; Make sure to read no more than LEN bytes since subsequent bytes may
512 ;; belong to the next response.
513 (case (response-code response)
514 ((200) ; hit
515 (let ((narinfo (read-narinfo port url #:size len)))
516 (cache-narinfo! cache (narinfo-path narinfo) narinfo)
517 (update-progress!)
518 narinfo))
519 ((404) ; failure
520 (let* ((path (uri-path (request-uri request)))
521 (hash-part (string-drop-right path 8))) ; drop ".narinfo"
522 (if len
523 (get-bytevector-n port len)
524 (read-to-eof port))
525 (cache-narinfo! cache
526 (find (cut string-contains <> hash-part) paths)
527 #f)
528 (update-progress!))
529 #f)
530 (else ; transient failure
531 (if len
532 (get-bytevector-n port len)
533 (read-to-eof port))
534 #f))))
536 (and (string=? (cache-store-directory cache) (%store-prefix))
537 (let ((uri (string->uri url)))
538 (case (and=> uri uri-scheme)
539 ((http)
540 (let ((requests (map (cut narinfo-request url <>) paths)))
541 (update-progress!)
542 (let ((result (http-multiple-get url requests
543 handle-narinfo-response)))
544 (newline (current-error-port))
545 result)))
546 ((file #f)
547 (let* ((base (string-append (uri-path uri) "/"))
548 (files (map (compose (cut string-append base <> ".narinfo")
549 store-path-hash-part)
550 paths)))
551 (filter-map (cut narinfo-from-file <> url) files)))
552 (else
553 (leave (_ "~s: unsupported server URI scheme~%")
554 (if uri (uri-scheme uri) url)))))))
556 (define (lookup-narinfos cache paths)
557 "Return the narinfos for PATHS, invoking the server at CACHE when no
558 information is available locally."
559 (let-values (((cached missing)
560 (fold2 (lambda (path cached missing)
561 (let-values (((valid? value)
562 (cached-narinfo path)))
563 (if valid?
564 (values (cons value cached) missing)
565 (values cached (cons path missing)))))
566 '()
567 '()
568 paths)))
569 (if (null? missing)
570 cached
571 (let* ((cache (force cache))
572 (missing (if cache
573 (fetch-narinfos cache missing)
574 '())))
575 (append cached missing)))))
577 (define (lookup-narinfo cache path)
578 "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
579 found."
580 (match (lookup-narinfos cache (list path))
581 ((answer) answer)))
583 (define (remove-expired-cached-narinfos)
584 "Remove expired narinfo entries from the cache. The sole purpose of this
585 function is to make sure `%narinfo-cache-directory' doesn't grow
586 indefinitely."
587 (define now
588 (current-time time-monotonic))
590 (define (expired? file)
591 (catch 'system-error
592 (lambda ()
593 (call-with-input-file file
594 (lambda (port)
595 (match (read port)
596 (('narinfo ('version 1) ('cache-uri _) ('date date)
597 ('value #f))
598 (obsolete? date now %narinfo-negative-ttl))
599 (('narinfo ('version 1) ('cache-uri _) ('date date)
600 ('value _))
601 (obsolete? date now %narinfo-ttl))
602 (_ #t)))))
603 (lambda args
604 ;; FILE may have been deleted.
605 #t)))
607 (for-each (lambda (file)
608 (let ((file (string-append %narinfo-cache-directory
609 "/" file)))
610 (when (expired? file)
611 ;; Wrap in `false-if-exception' because FILE might have been
612 ;; deleted in the meantime (TOCTTOU).
613 (false-if-exception (delete-file file)))))
614 (scandir %narinfo-cache-directory
615 (lambda (file)
616 (= (string-length file) 32)))))
618 (define (maybe-remove-expired-cached-narinfo)
619 "Remove expired narinfo entries from the cache if deemed necessary."
620 (define now
621 (current-time time-monotonic))
623 (define expiry-file
624 (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
626 (define last-expiry-date
627 (or (false-if-exception
628 (call-with-input-file expiry-file read))
629 0))
631 (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
632 (remove-expired-cached-narinfos)
633 (call-with-output-file expiry-file
634 (cute write (time-second now) <>))))
636 (define (progress-report-port report-progress port)
637 "Return a port that calls REPORT-PROGRESS every time something is read from
638 PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
639 `progress-proc'."
640 (define total 0)
641 (define (read! bv start count)
642 (let ((n (match (get-bytevector-n! port bv start count)
643 ((? eof-object?) 0)
644 (x x))))
645 (set! total (+ total n))
646 (report-progress total (const n))
647 ;; XXX: We're not in control, so we always return anyway.
648 n))
650 (make-custom-binary-input-port "progress-port-proc"
651 read! #f #f
652 (cut close-port port)))
654 (define-syntax with-networking
655 (syntax-rules ()
656 "Catch DNS lookup errors and gracefully exit."
657 ;; Note: no attempt is made to catch other networking errors, because DNS
658 ;; lookup errors are typically the first one, and because other errors are
659 ;; a subset of `system-error', which is harder to filter.
660 ((_ exp ...)
661 (catch 'getaddrinfo-error
662 (lambda () exp ...)
663 (lambda (key error)
664 (leave (_ "host name lookup error: ~a~%")
665 (gai-strerror error)))))))
667 \f
668 ;;;
669 ;;; Help.
670 ;;;
672 (define (show-help)
673 (display (_ "Usage: guix substitute [OPTION]...
674 Internal tool to substitute a pre-built binary to a local build.\n"))
675 (display (_ "
676 --query report on the availability of substitutes for the
677 store file names passed on the standard input"))
678 (display (_ "
679 --substitute STORE-FILE DESTINATION
680 download STORE-FILE and store it as a Nar in file
681 DESTINATION"))
682 (newline)
683 (display (_ "
684 -h, --help display this help and exit"))
685 (display (_ "
686 -V, --version display version information and exit"))
687 (newline)
688 (show-bug-report-information))
691 \f
692 ;;;
693 ;;; Entry point.
694 ;;;
696 (define (check-acl-initialized)
697 "Warn if the ACL is uninitialized."
698 (define (singleton? acl)
699 ;; True if ACL contains just the user's public key.
700 (and (file-exists? %public-key-file)
701 (let ((key (call-with-input-file %public-key-file
702 (compose string->canonical-sexp
703 get-string-all))))
704 (match acl
705 ((thing)
706 (equal? (canonical-sexp->string thing)
707 (canonical-sexp->string key)))
708 (_
709 #f)))))
711 (let ((acl (acl->public-keys (current-acl))))
712 (when (or (null? acl) (singleton? acl))
713 (warning (_ "ACL for archive imports seems to be uninitialized, \
714 substitutes may be unavailable\n")))))
716 (define (daemon-options)
717 "Return a list of name/value pairs denoting build daemon options."
718 (define %not-newline
719 (char-set-complement (char-set #\newline)))
721 (match (getenv "_NIX_OPTIONS")
722 (#f ;should not happen when called by the daemon
723 '())
724 (newline-separated
725 ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n".
726 (filter-map (lambda (option=value)
727 (match (string-index option=value #\=)
728 (#f ;invalid option setting
729 #f)
730 (equal-sign
731 (cons (string-take option=value equal-sign)
732 (string-drop option=value (+ 1 equal-sign))))))
733 (string-tokenize newline-separated %not-newline)))))
735 (define (find-daemon-option option)
736 "Return the value of build daemon option OPTION, or #f if it could not be
737 found."
738 (assoc-ref (daemon-options) option))
740 (define %cache-url
741 (match (and=> ;; TODO: Uncomment the following lines when multiple
742 ;; substitute sources are supported.
743 ;; (find-daemon-option "untrusted-substitute-urls") ;client
744 ;; " "
745 (find-daemon-option "substitute-urls") ;admin
746 string-tokenize)
747 ((url)
748 url)
749 ((head tail ..1)
750 ;; Currently we don't handle multiple substitute URLs.
751 (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
752 tail)
753 head)
754 (#f
755 ;; This can only happen when this script is not invoked by the
756 ;; daemon.
757 "http://hydra.gnu.org")))
759 (define (guix-substitute . args)
760 "Implement the build daemon's substituter protocol."
761 (mkdir-p %narinfo-cache-directory)
762 (maybe-remove-expired-cached-narinfo)
763 (check-acl-initialized)
765 ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
766 ;; when we know we cannot substitute, but we must emit a newline on stdout
767 ;; when everything is alright.
768 (let ((uri (string->uri %cache-url)))
769 (case (uri-scheme uri)
770 ((http)
771 ;; Exit gracefully if there's no network access.
772 (let ((host (uri-host uri)))
773 (catch 'getaddrinfo-error
774 (lambda ()
775 (getaddrinfo host))
776 (lambda (key error)
777 (warning (_ "failed to look up host '~a' (~a), \
778 substituter disabled~%")
779 host (gai-strerror error))
780 (exit 0)))))
781 (else #t)))
783 ;; Say hello (see above.)
784 (newline)
785 (force-output (current-output-port))
787 (with-networking
788 (with-error-handling ; for signature errors
789 (match args
790 (("--query")
791 (let ((cache (open-cache* %cache-url))
792 (acl (current-acl)))
793 (define (valid? obj)
794 (and (narinfo? obj) (valid-narinfo? obj acl)))
796 (let loop ((command (read-line)))
797 (or (eof-object? command)
798 (begin
799 (match (string-tokenize command)
800 (("have" paths ..1)
801 ;; Return the subset of PATHS available in CACHE.
802 (let ((substitutable
803 (if cache
804 (lookup-narinfos cache paths)
805 '())))
806 (for-each (lambda (narinfo)
807 (format #t "~a~%" (narinfo-path narinfo)))
808 (filter valid? substitutable))
809 (newline)))
810 (("info" paths ..1)
811 ;; Reply info about PATHS if it's in CACHE.
812 (let ((substitutable
813 (if cache
814 (lookup-narinfos cache paths)
815 '())))
816 (for-each (lambda (narinfo)
817 (format #t "~a\n~a\n~a\n"
818 (narinfo-path narinfo)
819 (or (and=> (narinfo-deriver narinfo)
820 (cute string-append
821 (%store-prefix) "/"
822 <>))
823 "")
824 (length (narinfo-references narinfo)))
825 (for-each (cute format #t "~a/~a~%"
826 (%store-prefix) <>)
827 (narinfo-references narinfo))
828 (format #t "~a\n~a\n"
829 (or (narinfo-file-size narinfo) 0)
830 (or (narinfo-size narinfo) 0)))
831 (filter valid? substitutable))
832 (newline)))
833 (wtf
834 (error "unknown `--query' command" wtf)))
835 (loop (read-line)))))))
836 (("--substitute" store-path destination)
837 ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
838 (let* ((cache (open-cache* %cache-url))
839 (narinfo (lookup-narinfo cache store-path))
840 (uri (narinfo-uri narinfo)))
841 ;; Make sure it is signed and everything.
842 (assert-valid-narinfo narinfo)
844 ;; Tell the daemon what the expected hash of the Nar itself is.
845 (format #t "~a~%" (narinfo-hash narinfo))
847 (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
848 store-path
850 ;; Use the Nar size as an estimate of the installed size.
851 (narinfo-size narinfo)
852 (and=> (narinfo-size narinfo)
853 (cute / <> (expt 2. 20))))
854 (let*-values (((raw download-size)
855 ;; Note that Hydra currently generates Nars on the fly
856 ;; and doesn't specify a Content-Length, so
857 ;; DOWNLOAD-SIZE is #f in practice.
858 (fetch uri #:buffered? #f #:timeout? #f))
859 ((progress)
860 (let* ((comp (narinfo-compression narinfo))
861 (dl-size (or download-size
862 (and (equal? comp "none")
863 (narinfo-size narinfo))))
864 (progress (progress-proc (uri-abbreviation uri)
865 dl-size
866 (current-error-port))))
867 (progress-report-port progress raw)))
868 ((input pids)
869 (decompressed-port (and=> (narinfo-compression narinfo)
870 string->symbol)
871 progress)))
872 ;; Unpack the Nar at INPUT into DESTINATION.
873 (restore-file input destination)
875 ;; Skip a line after what 'progress-proc' printed.
876 (newline (current-error-port))
878 (every (compose zero? cdr waitpid) pids))))
879 (("--version")
880 (show-version-and-exit "guix substitute"))
881 (("--help")
882 (show-help))
883 (opts
884 (leave (_ "~a: unrecognized options~%") opts))))))
887 ;;; Local Variables:
888 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
889 ;;; End:
891 ;;; substitute.scm ends here