1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
5 ;;; This file is part of GNU Guix.
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.
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.
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) #:hide (close-connection))
23 #:use-module (guix utils)
24 #:use-module (guix combinators)
25 #:use-module (guix config)
26 #:use-module (guix records)
27 #:use-module ((guix serialization) #:select (restore-file))
28 #:use-module (guix hash)
29 #:use-module (guix base32)
30 #:use-module (guix base64)
31 #:use-module (guix cache)
32 #:use-module (guix pk-crypto)
33 #:use-module (guix pki)
34 #:use-module ((guix build utils) #:select (mkdir-p dump-port))
35 #:use-module ((guix build download)
36 #:select (current-terminal-columns
37 progress-proc uri-abbreviation nar-uri-abbreviation
38 (open-connection-for-uri
39 . guix:open-connection-for-uri)
41 store-path-abbreviation byte-count->string))
42 #:use-module ((guix build syscalls)
43 #:select (set-thread-name))
44 #:use-module (ice-9 rdelim)
45 #:use-module (ice-9 regex)
46 #:use-module (ice-9 match)
47 #:use-module (ice-9 format)
48 #:use-module (ice-9 ftw)
49 #:use-module (ice-9 binary-ports)
50 #:use-module (ice-9 vlist)
51 #:use-module (rnrs bytevectors)
52 #:use-module (srfi srfi-1)
53 #:use-module (srfi srfi-9)
54 #:use-module (srfi srfi-11)
55 #:use-module (srfi srfi-19)
56 #:use-module (srfi srfi-26)
57 #:use-module (srfi srfi-34)
58 #:use-module (srfi srfi-35)
59 #:use-module (web uri)
60 #:use-module (web http)
61 #:use-module (web request)
62 #:use-module (web response)
63 #:use-module (guix http-client)
64 #:export (narinfo-signature->canonical-sexp
84 lookup-narinfos/diverse
91 ;;; This is the "binary substituter". It is invoked by the daemon do check
92 ;;; for the existence of available "substitutes" (pre-built binaries), and to
93 ;;; actually use them as a substitute to building things locally.
95 ;;; If possible, substitute a binary for the requested store path, using a Nix
96 ;;; "binary cache". This program implements the Nix "substituter" protocol.
102 ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
103 ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
104 (define time-monotonic time-tai))
107 (define %narinfo-cache-directory
108 ;; A local cache of narinfos, to avoid going to the network. Most of the
109 ;; time, 'guix substitute' is called by guix-daemon as root and stores its
110 ;; cached data in /var/guix/…. However, when invoked from 'guix challenge'
111 ;; as a user, it stores its cache in ~/.cache.
113 (or (and=> (getenv "XDG_CACHE_HOME")
114 (cut string-append <> "/guix/substitute"))
115 (string-append %state-directory "/substitute/cache"))
116 (string-append (cache-directory #:ensure? #f) "/substitute")))
118 (define %allow-unauthenticated-substitutes?
119 ;; Whether to allow unchecked substitutes. This is useful for testing
120 ;; purposes, and should be avoided otherwise.
121 (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
122 (cut string-ci=? <> "yes"))
124 (warning (G_ "authentication and authorization of substitutes \
129 ;; Number of seconds during which cached narinfo lookups are considered
130 ;; valid for substitute servers that do not advertise a TTL via the
131 ;; 'Cache-Control' response header.
134 (define %narinfo-negative-ttl
135 ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
138 (define %narinfo-transient-error-ttl
139 ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
142 (define %narinfo-expired-cache-entry-removal-delay
143 ;; How often we want to remove files corresponding to expired cache entries.
146 (define fields->alist
147 ;; The narinfo format is really just like recutils.
150 (define %fetch-timeout
151 ;; Number of seconds after which networking is considered "slow".
154 (define %random-state
155 (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
157 (define-syntax-rule (with-timeout duration handler body ...)
158 "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
163 (sigaction SIGALRM SIG_DFL)
173 ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
174 ;; because of the bug at
175 ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
176 ;; When that happens, try again. Note: SA_RESTART cannot be
177 ;; used because of <http://bugs.gnu.org/14640>.
178 (if (= EINTR (system-error-errno args))
180 ;; Wait a little to avoid bursts.
181 (usleep (random 3000000 %random-state))
183 (apply throw args))))))
186 (sigaction SIGALRM SIG_DFL)
187 (apply values result)))))
189 (define* (fetch uri #:key (buffered? #t) (timeout? #t))
190 "Return a binary input port to URI and the number of bytes it's expected to
192 (case (uri-scheme uri)
194 (let ((port (open-file (uri-path uri)
195 (if buffered? "rb" "r0b"))))
196 (values port (stat:size (stat port)))))
198 (guard (c ((http-get-error? c)
199 (leave (G_ "download from '~a' failed: ~a, ~s~%")
200 (uri->string (http-get-error-uri c))
201 (http-get-error-code c)
202 (http-get-error-reason c))))
204 ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
205 ;; and then cancel with:
206 ;; sudo tc qdisc del dev eth0 root
208 (with-timeout (if timeout?
212 (warning (G_ "while fetching ~a: server is somewhat slow~%")
214 (warning (G_ "try `--no-substitutes' if the problem persists~%"))
216 ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
217 ;; and thus PORT had to be closed and re-opened. This is not the
219 (unless (or (guile-version>? "2.0.9")
220 (version>? (version) "2.0.9.39"))
222 (close-connection port))))
224 (when (or (not port) (port-closed? port))
225 (set! port (guix:open-connection-for-uri
226 uri #:verify-certificate? #f))
227 (unless (or buffered? (not (file-port? port)))
228 (setvbuf port _IONBF)))
229 (http-fetch uri #:text? #f #:port port
230 #:verify-certificate? #f))))))
232 (leave (G_ "unsupported substitute URI scheme: ~a~%")
233 (uri->string uri)))))
235 (define-record-type <cache-info>
236 (%make-cache-info url store-directory wants-mass-query?)
239 (store-directory cache-info-store-directory)
240 (wants-mass-query? cache-info-wants-mass-query?))
242 (define (download-cache-info url)
243 "Download the information for the cache at URL. On success, return a
244 <cache-info> object and a port on which to send further HTTP requests. On
245 failure, return #f and #f."
247 (string->uri (string-append url "/nix-cache-info")))
249 (define (read-cache-info port)
250 (alist->record (fields->alist port)
251 (cut %make-cache-info url <...>)
252 '("StoreDir" "WantMassQuery")))
256 (case (uri-scheme uri)
258 (values (call-with-input-file (uri-path uri)
262 (let ((port (guix:open-connection-for-uri
264 #:verify-certificate? #f
265 #:timeout %fetch-timeout)))
266 (guard (c ((http-get-error? c)
267 (warning (G_ "while fetching '~a': ~a (~s)~%")
268 (uri->string (http-get-error-uri c))
269 (http-get-error-code c)
270 (http-get-error-reason c))
271 (close-connection port)
272 (warning (G_ "ignoring substitute server at '~s'~%") url)
274 (values (read-cache-info (http-fetch uri
275 #:verify-certificate? #f
281 ((getaddrinfo-error system-error)
282 ;; Silently ignore the error: probably due to lack of network access.
285 (apply throw key args))))))
288 (define-record-type <narinfo>
289 (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
290 references deriver system signature contents)
294 (uri-base narinfo-uri-base) ; URI of the cache it originates from
295 (compression narinfo-compression)
296 (file-hash narinfo-file-hash)
297 (file-size narinfo-file-size)
298 (nar-hash narinfo-hash)
299 (nar-size narinfo-size)
300 (references narinfo-references)
301 (deriver narinfo-deriver)
302 (system narinfo-system)
303 (signature narinfo-signature) ; canonical sexp
304 ;; The original contents of a narinfo file. This field is needed because we
305 ;; want to preserve the exact textual representation for verification purposes.
306 ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
307 ;; for more information.
308 (contents narinfo-contents))
310 (define (narinfo-hash->sha256 hash)
311 "If the string HASH denotes a sha256 hash, return it as a bytevector.
312 Otherwise return #f."
313 (and (string-prefix? "sha256:" hash)
314 (nix-base32-string->bytevector (string-drop hash 7))))
316 (define (narinfo-signature->canonical-sexp str)
317 "Return the value of a narinfo's 'Signature' field as a canonical sexp."
318 (match (string-split str #\;)
319 ((version host-name sig)
320 (let ((maybe-number (string->number version)))
321 (cond ((not (number? maybe-number))
322 (leave (G_ "signature version must be a number: ~s~%")
324 ;; Currently, there are no other versions.
325 ((not (= 1 maybe-number))
326 (leave (G_ "unsupported signature version: ~a~%")
329 (let ((signature (utf8->string (base64-decode sig))))
332 (string->canonical-sexp signature))
333 (lambda (key proc err)
334 (leave (G_ "signature is not a valid \
338 (leave (G_ "invalid format of the signature field: ~a~%") x))))
340 (define (narinfo-maker str cache-url)
341 "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
342 must contain the original contents of a narinfo file."
343 (lambda (path url compression file-hash file-size nar-hash nar-size
344 references deriver system signature)
345 "Return a new <narinfo> object."
347 ;; Handle the case where URL is a relative URL.
348 (or (string->uri url)
349 (string->uri (string-append cache-url "/" url)))
352 compression file-hash
353 (and=> file-size string->number)
355 (and=> nar-size string->number)
356 (string-tokenize references)
362 (and=> signature narinfo-signature->canonical-sexp))
365 (define* (assert-valid-signature narinfo signature hash
366 #:optional (acl (current-acl)))
367 "Bail out if SIGNATURE, a canonical sexp representing the signature of
368 NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
369 (let ((uri (uri->string (narinfo-uri narinfo))))
370 (signature-case (signature hash acl)
373 (leave (G_ "invalid signature for '~a'~%") uri))
375 (leave (G_ "hash mismatch for '~a'~%") uri))
377 (leave (G_ "'~a' is signed with an unauthorized key~%") uri))
379 (leave (G_ "signature on '~a' is corrupt~%") uri)))))
381 (define* (read-narinfo port #:optional url
383 "Read a narinfo from PORT. If URL is true, it must be a string used to
384 build full URIs from relative URIs found while reading PORT. When SIZE is
385 true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
387 No authentication and authorization checks are performed here!"
388 (let ((str (utf8->string (if size
389 (get-bytevector-n port size)
390 (get-bytevector-all port)))))
391 (alist->record (call-with-input-string str fields->alist)
392 (narinfo-maker str url)
393 '("StorePath" "URL" "Compression"
394 "FileHash" "FileSize" "NarHash" "NarSize"
395 "References" "Deriver" "System"
398 (define (narinfo-sha256 narinfo)
399 "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
401 (let ((contents (narinfo-contents narinfo)))
402 (match (string-contains contents "Signature:")
405 (let ((above-signature (string-take contents index)))
406 (sha256 (string->utf8 above-signature)))))))
408 (define* (assert-valid-narinfo narinfo
409 #:optional (acl (current-acl))
411 "Raise an exception if NARINFO lacks a signature, has an invalid signature,
412 or is signed by an unauthorized key."
413 (let ((hash (narinfo-sha256 narinfo)))
415 (if %allow-unauthenticated-substitutes?
417 (leave (G_ "substitute at '~a' lacks a signature~%")
418 (uri->string (narinfo-uri narinfo))))
419 (let ((signature (narinfo-signature narinfo)))
420 (unless %allow-unauthenticated-substitutes?
421 (assert-valid-signature narinfo signature hash acl)
423 (format (current-error-port)
424 (G_ "Found valid signature for ~a~%")
425 (narinfo-path narinfo))
426 (format (current-error-port)
428 (uri->string (narinfo-uri narinfo)))))
431 (define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
432 "Return #t if NARINFO's signature is not valid."
433 (or %allow-unauthenticated-substitutes?
434 (let ((hash (narinfo-sha256 narinfo))
435 (signature (narinfo-signature narinfo)))
437 (signature-case (signature hash acl)
441 (define (write-narinfo narinfo port)
442 "Write NARINFO to PORT."
443 (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
445 (define (narinfo->string narinfo)
446 "Return the external representation of NARINFO."
447 (call-with-output-string (cut write-narinfo narinfo <>)))
449 (define (string->narinfo str cache-uri)
450 "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
451 the cache STR originates form."
452 (call-with-input-string str (cut read-narinfo <> cache-uri)))
454 (define (narinfo-cache-file cache-url path)
455 "Return the name of the local file that contains an entry for PATH. The
456 entry is stored in a sub-directory specific to CACHE-URL."
457 ;; The daemon does not sanitize its input, so PATH could be something like
458 ;; "/gnu/store/foo". Gracefully handle that.
459 (match (store-path-hash-part path)
461 (leave (G_ "'~a' does not name a store item~%") path))
462 ((? string? hash-part)
463 (string-append %narinfo-cache-directory "/"
464 (bytevector->base32-string (sha256 (string->utf8 cache-url)))
467 (define (cached-narinfo cache-url path)
468 "Check locally if we have valid info about PATH coming from CACHE-URL.
469 Return two values: a Boolean indicating whether we have valid cached info, and
470 that info, which may be either #f (when PATH is unavailable) or the narinfo
473 (current-time time-monotonic))
476 (narinfo-cache-file cache-url path))
480 (call-with-input-file cache-file
483 (('narinfo ('version 2)
484 ('cache-uri cache-uri)
485 ('date date) ('ttl ttl) ('value #f))
486 ;; A cached negative lookup.
487 (if (obsolete? date now ttl)
490 (('narinfo ('version 2)
491 ('cache-uri cache-uri)
492 ('date date) ('ttl ttl) ('value value))
493 ;; A cached positive lookup
494 (if (obsolete? date now ttl)
496 (values #t (string->narinfo value cache-uri))))
497 (('narinfo ('version v) _ ...)
502 (define (cache-narinfo! cache-url path narinfo ttl)
503 "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
504 given TTL (a number of seconds or #f). NARINFO may be #f, in which case it
505 indicates that PATH is unavailable at CACHE-URL."
507 (current-time time-monotonic))
509 (define (cache-entry cache-uri narinfo)
510 `(narinfo (version 2)
511 (cache-uri ,cache-uri)
512 (date ,(time-second now))
514 (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
515 (value ,(and=> narinfo narinfo->string))))
517 (let ((file (narinfo-cache-file cache-url path)))
518 (mkdir-p (dirname file))
519 (with-atomic-file-output file
521 (write (cache-entry cache-url narinfo) out))))
525 (define (narinfo-request cache-url path)
526 "Return an HTTP request for the narinfo of PATH at CACHE-URL."
527 (let ((url (string-append cache-url "/" (store-path-hash-part path)
529 (headers '((User-Agent . "GNU Guile"))))
530 (build-request (string->uri url) #:method 'GET #:headers headers)))
532 (define* (http-multiple-get base-uri proc seed requests
533 #:key port (verify-certificate? #t))
534 "Send all of REQUESTS to the server at BASE-URI. Call PROC for each
535 response, passing it the request object, the response, a port from which to
536 read the response body, and the previous result, starting with SEED, à la
537 'fold'. Return the final result. When PORT is specified, use it as the
538 initial connection on which HTTP requests are sent."
539 (let connect ((port port)
542 ;; (format (current-error-port) "connecting (~a requests left)..."
543 ;; (length requests))
544 (let ((p (or port (guix:open-connection-for-uri
546 #:verify-certificate?
547 verify-certificate?))))
548 ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
550 (setvbuf p _IOFBF (expt 2 16)))
552 ;; Send all of REQUESTS in a row.
553 ;; XXX: Do our own caching to work around inefficiencies when
554 ;; communicating over TLS: <http://bugs.gnu.org/22966>.
555 (let-values (((buffer get) (open-bytevector-output-port)))
556 ;; On Guile > 2.0.9, inherit the HTTP proxying property from P.
557 (when (module-variable (resolve-interface '(web http))
559 (set-http-proxy-port?! buffer (http-proxy-port? p)))
561 (for-each (cut write-request <> buffer) requests)
562 (put-bytevector p (get))
565 ;; Now start processing responses.
566 (let loop ((requests requests)
572 (let* ((resp (read-response p))
573 (body (response-body-port resp))
574 (result (proc head resp body result)))
575 ;; The server can choose to stop responding at any time, in which
576 ;; case we have to try again. Check whether that is the case.
577 ;; Note that even upon "Connection: close", we can read from BODY.
578 (match (assq 'connection (response-headers resp))
579 (('connection 'close)
581 (connect #f tail result)) ;try again
583 (loop tail result)))))))))) ;keep going
585 (define (read-to-eof port)
586 "Read from PORT until EOF is reached. The data are discarded."
587 (dump-port port (%make-void-port "w")))
589 (define (narinfo-from-file file url)
590 "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
591 if file doesn't exist, and the narinfo otherwise."
594 (call-with-input-file file
595 (cut read-narinfo <> url)))
597 (if (= ENOENT (system-error-errno args))
599 (apply throw args)))))
601 (define (fetch-narinfos url paths)
602 "Retrieve all the narinfos for PATHS from the cache at URL and return them."
603 (define update-progress!
605 (total (length paths)))
607 (display #\cr (current-error-port))
608 (force-output (current-error-port))
609 (format (current-error-port)
610 (G_ "updating list of substitutes from '~a'... ~5,1f%")
611 url (* 100. (/ done total)))
612 (set! done (+ 1 done)))))
614 (define hash-part->path
615 (let ((mapping (fold (lambda (path result)
616 (vhash-cons (store-path-hash-part path) path
621 (match (vhash-assoc hash mapping)
623 ((_ . path) path)))))
625 (define (handle-narinfo-response request response port result)
626 (let* ((code (response-code response))
627 (len (response-content-length response))
628 (cache (response-cache-control response))
629 (ttl (and cache (assoc-ref cache 'max-age))))
630 ;; Make sure to read no more than LEN bytes since subsequent bytes may
631 ;; belong to the next response.
632 (if (= code 200) ; hit
633 (let ((narinfo (read-narinfo port url #:size len)))
634 (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
636 (cons narinfo result))
637 (let* ((path (uri-path (request-uri request)))
639 (string-drop-right path 8)))) ;drop ".narinfo"
641 (get-bytevector-n port len)
643 (cache-narinfo! url (hash-part->path hash-part) #f
646 %narinfo-transient-error-ttl))
650 (define (do-fetch uri port)
651 (case (and=> uri uri-scheme)
653 (let ((requests (map (cut narinfo-request url <>) paths)))
656 ;; Note: Do not check HTTPS server certificates to avoid depending on
657 ;; the X.509 PKI. We can do it because we authenticate narinfos,
658 ;; which provides a much stronger guarantee.
659 (let ((result (http-multiple-get uri
660 handle-narinfo-response '()
662 #:verify-certificate? #f
664 (close-connection port)
665 (newline (current-error-port))
668 (let* ((base (string-append (uri-path uri) "/"))
669 (files (map (compose (cut string-append base <> ".narinfo")
670 store-path-hash-part)
672 (filter-map (cut narinfo-from-file <> url) files)))
674 (leave (G_ "~s: unsupported server URI scheme~%")
675 (if uri (uri-scheme uri) url)))))
677 (let-values (((cache-info port)
678 (download-cache-info url)))
680 (if (string=? (cache-info-store-directory cache-info)
682 (do-fetch (string->uri url) port) ;reuse PORT
684 (warning (G_ "'~a' uses different store '~a'; ignoring it~%")
685 url (cache-info-store-directory cache-info))
686 (close-connection port)
689 (define (lookup-narinfos cache paths)
690 "Return the narinfos for PATHS, invoking the server at CACHE when no
691 information is available locally."
692 (let-values (((cached missing)
693 (fold2 (lambda (path cached missing)
694 (let-values (((valid? value)
695 (cached-narinfo cache path)))
698 (values (cons value cached) missing)
699 (values cached missing))
700 (values cached (cons path missing)))))
706 (let ((missing (fetch-narinfos cache missing)))
707 (append cached (or missing '()))))))
709 (define (lookup-narinfos/diverse caches paths)
710 "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
711 That is, when a cache lacks a narinfo, look it up in the next cache, and so
712 on. Return a list of narinfos for PATHS or a subset thereof."
713 (let loop ((caches caches)
722 (let* ((narinfos (lookup-narinfos cache paths))
723 (hits (map narinfo-path narinfos))
724 (missing (lset-difference string=? paths hits))) ;XXX: perf
725 (loop rest missing (append narinfos result))))
729 (define (lookup-narinfo caches path)
730 "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
732 (match (lookup-narinfos/diverse caches (list path))
736 (define (cached-narinfo-expiration-time file)
737 "Return the expiration time for FILE, which is a cached narinfo."
740 (call-with-input-file file
743 (('narinfo ('version 2) ('cache-uri uri)
744 ('date date) ('ttl ttl) ('value #f))
746 (('narinfo ('version 2) ('cache-uri uri)
747 ('date date) ('ttl ttl) ('value value))
752 ;; FILE may have been deleted.
755 (define (narinfo-cache-directories directory)
756 "Return the list of narinfo cache directories (one per cache URL.)"
757 (map (cut string-append directory "/" <>)
758 (scandir %narinfo-cache-directory
760 (and (not (member item '("." "..")))
762 (string-append %narinfo-cache-directory
765 (define* (cached-narinfo-files #:optional
766 (directory %narinfo-cache-directory))
767 "Return the list of cached narinfo files under DIRECTORY."
768 (append-map (lambda (directory)
769 (map (cut string-append directory "/" <>)
772 (= (string-length file) 32)))))
773 (narinfo-cache-directories directory)))
775 (define (progress-report-port report-progress port)
776 "Return a port that calls REPORT-PROGRESS every time something is read from
777 PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
780 (define (read! bv start count)
781 (let ((n (match (get-bytevector-n! port bv start count)
784 (set! total (+ total n))
785 (report-progress total (const n))
786 ;; XXX: We're not in control, so we always return anyway.
789 (make-custom-binary-input-port "progress-port-proc"
791 (cut close-connection port)))
793 (define-syntax with-networking
795 "Catch DNS lookup errors and TLS errors and gracefully exit."
796 ;; Note: no attempt is made to catch other networking errors, because DNS
797 ;; lookup errors are typically the first one, and because other errors are
798 ;; a subset of `system-error', which is harder to filter.
803 (('getaddrinfo-error error)
804 (leave (G_ "host name lookup error: ~a~%")
805 (gai-strerror error)))
806 (('gnutls-error error proc . rest)
807 (let ((error->string (module-ref (resolve-interface '(gnutls))
809 (leave (G_ "TLS error in procedure '~a': ~a~%")
810 proc (error->string error))))
812 (apply throw args)))))))
820 (display (G_ "Usage: guix substitute [OPTION]...
821 Internal tool to substitute a pre-built binary to a local build.\n"))
823 --query report on the availability of substitutes for the
824 store file names passed on the standard input"))
826 --substitute STORE-FILE DESTINATION
827 download STORE-FILE and store it as a Nar in file
831 -h, --help display this help and exit"))
833 -V, --version display version information and exit"))
835 (show-bug-report-information))
840 ;;; Daemon/substituter protocol.
843 (define (display-narinfo-data narinfo)
844 "Write to the current output port the contents of NARINFO in the format
845 expected by the daemon."
846 (format #t "~a\n~a\n~a\n"
847 (narinfo-path narinfo)
848 (or (and=> (narinfo-deriver narinfo)
849 (cute string-append (%store-prefix) "/" <>))
851 (length (narinfo-references narinfo)))
852 (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
853 (narinfo-references narinfo))
854 (format #t "~a\n~a\n"
855 (or (narinfo-file-size narinfo) 0)
856 (or (narinfo-size narinfo) 0)))
858 (define* (process-query command
859 #:key cache-urls acl)
860 "Reply to COMMAND, a query as written by the daemon to this process's
861 standard input. Use ACL as the access-control list against which to check
862 authorized substitutes."
864 (valid-narinfo? obj acl))
866 (match (string-tokenize command)
868 ;; Return the subset of PATHS available in CACHE-URLS.
869 (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
870 (for-each (lambda (narinfo)
871 (format #t "~a~%" (narinfo-path narinfo)))
872 (filter valid? substitutable))
875 ;; Reply info about PATHS if it's in CACHE-URLS.
876 (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
877 (for-each display-narinfo-data (filter valid? substitutable))
880 (error "unknown `--query' command" wtf))))
882 (define* (process-substitution store-item destination
883 #:key cache-urls acl)
884 "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
885 DESTINATION as a nar file. Verify the substitute against ACL."
886 (let* ((narinfo (lookup-narinfo cache-urls store-item))
887 (uri (narinfo-uri narinfo)))
888 ;; Make sure it is signed and everything.
889 (assert-valid-narinfo narinfo acl)
891 ;; Tell the daemon what the expected hash of the Nar itself is.
892 (format #t "~a~%" (narinfo-hash narinfo))
894 (format (current-error-port)
895 (G_ "Downloading ~a...~%") (uri->string uri))
896 (let*-values (((raw download-size)
897 ;; Note that Hydra currently generates Nars on the fly
898 ;; and doesn't specify a Content-Length, so
899 ;; DOWNLOAD-SIZE is #f in practice.
900 (fetch uri #:buffered? #f #:timeout? #f))
902 (let* ((comp (narinfo-compression narinfo))
903 (dl-size (or download-size
904 (and (equal? comp "none")
905 (narinfo-size narinfo))))
906 (progress (progress-proc (uri->string uri)
910 nar-uri-abbreviation)))
911 (progress-report-port progress raw)))
913 (decompressed-port (and=> (narinfo-compression narinfo)
916 ;; Unpack the Nar at INPUT into DESTINATION.
917 (restore-file input destination)
919 ;; Skip a line after what 'progress-proc' printed, and another one to
920 ;; visually separate substitutions.
921 (display "\n\n" (current-error-port))
923 (every (compose zero? cdr waitpid) pids))))
930 (define (check-acl-initialized)
931 "Warn if the ACL is uninitialized."
932 (define (singleton? acl)
933 ;; True if ACL contains just the user's public key.
934 (and (file-exists? %public-key-file)
935 (let ((key (call-with-input-file %public-key-file
936 (compose string->canonical-sexp
940 (equal? (canonical-sexp->string thing)
941 (canonical-sexp->string key)))
945 (let ((acl (acl->public-keys (current-acl))))
946 (when (or (null? acl) (singleton? acl))
947 (warning (G_ "ACL for archive imports seems to be uninitialized, \
948 substitutes may be unavailable\n")))))
950 (define (daemon-options)
951 "Return a list of name/value pairs denoting build daemon options."
953 (char-set-complement (char-set #\newline)))
955 (match (getenv "_NIX_OPTIONS")
956 (#f ;should not happen when called by the daemon
959 ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n".
960 (filter-map (lambda (option=value)
961 (match (string-index option=value #\=)
962 (#f ;invalid option setting
965 (cons (string-take option=value equal-sign)
966 (string-drop option=value (+ 1 equal-sign))))))
967 (string-tokenize newline-separated %not-newline)))))
969 (define (find-daemon-option option)
970 "Return the value of build daemon option OPTION, or #f if it could not be
972 (assoc-ref (daemon-options) option))
975 (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client
976 (find-daemon-option "substitute-urls")) ;admin
981 ;; This can only happen when this script is not invoked by the
983 '("http://hydra.gnu.org"))))
985 (define (client-terminal-columns)
986 "Return the number of columns in the client's terminal, if it is known, or a
988 (or (and=> (or (find-daemon-option "untrusted-terminal-columns")
989 (find-daemon-option "terminal-columns"))
991 (let ((number (string->number str)))
992 (and number (max 20 (- number 1))))))
995 (define (validate-uri uri)
996 (unless (string->uri uri)
997 (leave (G_ "~a: invalid URI~%") uri)))
999 (define (guix-substitute . args)
1000 "Implement the build daemon's substituter protocol."
1001 (mkdir-p %narinfo-cache-directory)
1002 (maybe-remove-expired-cache-entries %narinfo-cache-directory
1003 cached-narinfo-files
1005 cached-narinfo-expiration-time
1007 %narinfo-expired-cache-entry-removal-delay)
1008 (check-acl-initialized)
1010 ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
1011 ;; when we know we cannot substitute, but we must emit a newline on stdout
1012 ;; when everything is alright.
1013 (when (null? %cache-urls)
1016 ;; Say hello (see above.)
1018 (force-output (current-output-port))
1020 ;; Sanity-check %CACHE-URLS so we can provide a meaningful error message.
1021 (for-each validate-uri %cache-urls)
1023 ;; Attempt to install the client's locale, mostly so that messages are
1024 ;; suitably translated.
1025 (match (or (find-daemon-option "untrusted-locale")
1026 (find-daemon-option "locale"))
1028 (locale (false-if-exception (setlocale LC_ALL locale))))
1030 (set-thread-name "guix substitute")
1033 (with-error-handling ; for signature errors
1036 (let ((acl (current-acl)))
1037 (let loop ((command (read-line)))
1038 (or (eof-object? command)
1040 (process-query command
1041 #:cache-urls %cache-urls
1043 (loop (read-line)))))))
1044 (("--substitute" store-path destination)
1045 ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
1046 ;; Specify the number of columns of the terminal so the progress
1047 ;; report displays nicely.
1048 (parameterize ((current-terminal-columns (client-terminal-columns)))
1049 (process-substitution store-path destination
1050 #:cache-urls %cache-urls
1051 #:acl (current-acl))))
1053 (show-version-and-exit "guix substitute"))
1057 (leave (G_ "~a: unrecognized options~%") opts))))))
1059 ;;; Local Variables:
1060 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
1063 ;;; substitute.scm ends here