| blob | 31559b7966447472c2b494cb12a2c9bb8225c261 |
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 ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
161 ;; honor TIMEOUT? to disable the timeout when fetching a nar.
162 ;;
163 ;; Test this with:
164 ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
165 ;; and then cancel with:
166 ;; sudo tc qdisc del dev eth0 root
167 (let ((port #f))
168 (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
169 %fetch-timeout
170 0)
171 (begin
172 (warning (_ "while fetching ~a: server is somewhat slow~%")
173 (uri->string uri))
174 (warning (_ "try `--no-substitutes' if the problem persists~%"))
176 ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
177 ;; and thus PORT had to be closed and re-opened. This is not the
178 ;; case afterward.
179 (unless (or (guile-version>? "2.0.9")
180 (version>? (version) "2.0.9.39"))
181 (when port
182 (close-port port))))
183 (begin
184 (when (or (not port) (port-closed? port))
185 (set! port (open-socket-for-uri uri))
186 (unless buffered?
187 (setvbuf port _IONBF)))
188 (http-fetch uri #:text? #f #:port port))))))))
190 (define-record-type <cache>
191 (%make-cache url store-directory wants-mass-query?)
192 cache?
193 (url cache-url)
194 (store-directory cache-store-directory)
195 (wants-mass-query? cache-wants-mass-query?))
197 (define (open-cache url)
198 "Open the binary cache at URL. Return a <cache> object on success, or #f on
199 failure."
200 (define (download-cache-info url)
201 ;; Download the `nix-cache-info' from URL, and return its contents as an
202 ;; list of key/value pairs.
203 (and=> (false-if-exception (fetch (string->uri url)))
204 fields->alist))
206 (and=> (download-cache-info (string-append url "/nix-cache-info"))
207 (lambda (properties)
208 (alist->record properties
209 (cut %make-cache url <...>)
210 '("StoreDir" "WantMassQuery")))))
212 (define-syntax-rule (open-cache* url)
213 "Delayed variant of 'open-cache' that also lets the user know that they're
214 gonna have to wait."
215 (delay (begin
216 (format (current-error-port)
217 (_ "updating list of substitutes from '~a'...\r")
218 url)
219 (open-cache url))))
221 (define-record-type <narinfo>
222 (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
223 references deriver system signature contents)
224 narinfo?
225 (path narinfo-path)
226 (uri narinfo-uri)
227 (uri-base narinfo-uri-base) ; URI of the cache it originates from
228 (compression narinfo-compression)
229 (file-hash narinfo-file-hash)
230 (file-size narinfo-file-size)
231 (nar-hash narinfo-hash)
232 (nar-size narinfo-size)
233 (references narinfo-references)
234 (deriver narinfo-deriver)
235 (system narinfo-system)
236 (signature narinfo-signature) ; canonical sexp
237 ;; The original contents of a narinfo file. This field is needed because we
238 ;; want to preserve the exact textual representation for verification purposes.
239 ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
240 ;; for more information.
241 (contents narinfo-contents))
243 (define (narinfo-signature->canonical-sexp str)
244 "Return the value of a narinfo's 'Signature' field as a canonical sexp."
245 (match (string-split str #\;)
246 ((version _ sig)
247 (let ((maybe-number (string->number version)))
248 (cond ((not (number? maybe-number))
249 (leave (_ "signature version must be a number: ~s~%")
250 version))
251 ;; Currently, there are no other versions.
252 ((not (= 1 maybe-number))
253 (leave (_ "unsupported signature version: ~a~%")
254 maybe-number))
255 (else
256 (let ((signature (utf8->string (base64-decode sig))))
257 (catch 'gcry-error
258 (lambda ()
259 (string->canonical-sexp signature))
260 (lambda (key proc err)
261 (leave (_ "signature is not a valid \
262 s-expression: ~s~%")
263 signature))))))))
264 (x
265 (leave (_ "invalid format of the signature field: ~a~%") x))))
267 (define (narinfo-maker str cache-url)
268 "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
269 must contain the original contents of a narinfo file."
270 (lambda (path url compression file-hash file-size nar-hash nar-size
271 references deriver system signature)
272 "Return a new <narinfo> object."
273 (%make-narinfo path
274 ;; Handle the case where URL is a relative URL.
275 (or (string->uri url)
276 (string->uri (string-append cache-url "/" url)))
277 cache-url
279 compression file-hash
280 (and=> file-size string->number)
281 nar-hash
282 (and=> nar-size string->number)
283 (string-tokenize references)
284 (match deriver
285 ((or #f "") #f)
286 (_ deriver))
287 system
288 (false-if-exception
289 (and=> signature narinfo-signature->canonical-sexp))
290 str)))
292 (define* (assert-valid-signature narinfo signature hash
293 #:optional (acl (current-acl)))
294 "Bail out if SIGNATURE, a canonical sexp representing the signature of
295 NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
296 (let ((uri (uri->string (narinfo-uri narinfo))))
297 (signature-case (signature hash acl)
298 (valid-signature #t)
299 (invalid-signature
300 (leave (_ "invalid signature for '~a'~%") uri))
301 (hash-mismatch
302 (leave (_ "hash mismatch for '~a'~%") uri))
303 (unauthorized-key
304 (leave (_ "'~a' is signed with an unauthorized key~%") uri))
305 (corrupt-signature
306 (leave (_ "signature on '~a' is corrupt~%") uri)))))
308 (define* (read-narinfo port #:optional url
309 #:key size)
310 "Read a narinfo from PORT. If URL is true, it must be a string used to
311 build full URIs from relative URIs found while reading PORT. When SIZE is
312 true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
314 No authentication and authorization checks are performed here!"
315 (let ((str (utf8->string (if size
316 (get-bytevector-n port size)
317 (get-bytevector-all port)))))
318 (alist->record (call-with-input-string str fields->alist)
319 (narinfo-maker str url)
320 '("StorePath" "URL" "Compression"
321 "FileHash" "FileSize" "NarHash" "NarSize"
322 "References" "Deriver" "System"
323 "Signature"))))
325 (define (narinfo-sha256 narinfo)
326 "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
327 'Signature' field."
328 (let ((contents (narinfo-contents narinfo)))
329 (match (string-contains contents "Signature:")
330 (#f #f)
331 (index
332 (let ((above-signature (string-take contents index)))
333 (sha256 (string->utf8 above-signature)))))))
335 (define* (assert-valid-narinfo narinfo
336 #:optional (acl (current-acl))
337 #:key (verbose? #t))
338 "Raise an exception if NARINFO lacks a signature, has an invalid signature,
339 or is signed by an unauthorized key."
340 (let ((hash (narinfo-sha256 narinfo)))
341 (if (not hash)
342 (if %allow-unauthenticated-substitutes?
343 narinfo
344 (leave (_ "substitute at '~a' lacks a signature~%")
345 (uri->string (narinfo-uri narinfo))))
346 (let ((signature (narinfo-signature narinfo)))
347 (unless %allow-unauthenticated-substitutes?
348 (assert-valid-signature narinfo signature hash acl)
349 (when verbose?
350 (format (current-error-port)
351 "found valid signature for '~a', from '~a'~%"
352 (narinfo-path narinfo)
353 (uri->string (narinfo-uri narinfo)))))
354 narinfo))))
356 (define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
357 "Return #t if NARINFO's signature is not valid."
358 (or %allow-unauthenticated-substitutes?
359 (let ((hash (narinfo-sha256 narinfo))
360 (signature (narinfo-signature narinfo)))
361 (and hash signature
362 (signature-case (signature hash acl)
363 (valid-signature #t)
364 (else #f))))))
366 (define (write-narinfo narinfo port)
367 "Write NARINFO to PORT."
368 (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
370 (define (narinfo->string narinfo)
371 "Return the external representation of NARINFO."
372 (call-with-output-string (cut write-narinfo narinfo <>)))
374 (define (string->narinfo str cache-uri)
375 "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
376 the cache STR originates form."
377 (call-with-input-string str (cut read-narinfo <> cache-uri)))
379 (define (obsolete? date now ttl)
380 "Return #t if DATE is obsolete compared to NOW + TTL seconds."
381 (time>? (subtract-duration now (make-time time-duration 0 ttl))
382 (make-time time-monotonic 0 date)))
385 (define (narinfo-cache-file path)
386 "Return the name of the local file that contains an entry for PATH."
387 (string-append %narinfo-cache-directory "/"
388 (store-path-hash-part path)))
390 (define (cached-narinfo path)
391 "Check locally if we have valid info about PATH. Return two values: a
392 Boolean indicating whether we have valid cached info, and that info, which may
393 be either #f (when PATH is unavailable) or the narinfo for PATH."
394 (define now
395 (current-time time-monotonic))
397 (define cache-file
398 (narinfo-cache-file path))
400 (catch 'system-error
401 (lambda ()
402 (call-with-input-file cache-file
403 (lambda (p)
404 (match (read p)
405 (('narinfo ('version 1)
406 ('cache-uri cache-uri)
407 ('date date) ('value #f))
408 ;; A cached negative lookup.
409 (if (obsolete? date now %narinfo-negative-ttl)
410 (values #f #f)
411 (values #t #f)))
412 (('narinfo ('version 1)
413 ('cache-uri cache-uri)
414 ('date date) ('value value))
415 ;; A cached positive lookup
416 (if (obsolete? date now %narinfo-ttl)
417 (values #f #f)
418 (values #t (string->narinfo value cache-uri))))
419 (('narinfo ('version v) _ ...)
420 (values #f #f))))))
421 (lambda _
422 (values #f #f))))
424 (define (cache-narinfo! cache path narinfo)
425 "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may
426 be #f, in which case it indicates that PATH is unavailable at CACHE."
427 (define now
428 (current-time time-monotonic))
430 (define (cache-entry cache-uri narinfo)
431 `(narinfo (version 1)
432 (cache-uri ,cache-uri)
433 (date ,(time-second now))
434 (value ,(and=> narinfo narinfo->string))))
436 (with-atomic-file-output (narinfo-cache-file path)
437 (lambda (out)
438 (write (cache-entry (cache-url cache) narinfo) out)))
439 narinfo)
441 (define (narinfo-request cache-url path)
442 "Return an HTTP request for the narinfo of PATH at CACHE-URL."
443 (let ((url (string-append cache-url "/" (store-path-hash-part path)
444 ".narinfo")))
445 (build-request (string->uri url) #:method 'GET)))
447 (define (http-multiple-get base-url requests proc)
448 "Send all of REQUESTS to the server at BASE-URL. Call PROC for each
449 response, passing it the request object, the response, and a port from which
450 to read the response body. Return the list of results."
451 (let connect ((requests requests)
452 (result '()))
453 ;; (format (current-error-port) "connecting (~a requests left)..."
454 ;; (length requests))
455 (let ((p (open-socket-for-uri base-url)))
456 ;; Send all of REQUESTS in a row.
457 (setvbuf p _IOFBF (expt 2 16))
458 (for-each (cut write-request <> p) requests)
459 (force-output p)
461 ;; Now start processing responses.
462 (let loop ((requests requests)
463 (result result))
464 (match requests
465 (()
466 (reverse result))
467 ((head tail ...)
468 (let* ((resp (read-response p))
469 (body (response-body-port resp)))
470 ;; The server can choose to stop responding at any time, in which
471 ;; case we have to try again. Check whether that is the case.
472 (match (assq 'connection (response-headers resp))
473 (('connection 'close)
474 (close-port p)
475 (connect requests result)) ;try again
476 (_
477 (loop tail ;keep going
478 (cons (proc head resp body) result)))))))))))
480 (define (read-to-eof port)
481 "Read from PORT until EOF is reached. The data are discarded."
482 (dump-port port (%make-void-port "w")))
484 (define (narinfo-from-file file url)
485 "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
486 if file doesn't exist, and the narinfo otherwise."
487 (catch 'system-error
488 (lambda ()
489 (call-with-input-file file
490 (cut read-narinfo <> url)))
491 (lambda args
492 (if (= ENOENT (system-error-errno args))
493 #f
494 (apply throw args)))))
496 (define (fetch-narinfos cache paths)
497 "Retrieve all the narinfos for PATHS from CACHE and return them."
498 (define url
499 (cache-url cache))
501 (define update-progress!
502 (let ((done 0))
503 (lambda ()
504 (display #\cr (current-error-port))
505 (force-output (current-error-port))
506 (format (current-error-port)
507 (_ "updating list of substitutes from '~a'... ~5,1f%")
508 url (* 100. (/ done (length paths))))
509 (set! done (+ 1 done)))))
511 (define (handle-narinfo-response request response port)
512 (let ((len (response-content-length response)))
513 ;; Make sure to read no more than LEN bytes since subsequent bytes may
514 ;; belong to the next response.
515 (case (response-code response)
516 ((200) ; hit
517 (let ((narinfo (read-narinfo port url #:size len)))
518 (cache-narinfo! cache (narinfo-path narinfo) narinfo)
519 (update-progress!)
520 narinfo))
521 ((404) ; failure
522 (let* ((path (uri-path (request-uri request)))
523 (hash-part (string-drop-right path 8))) ; drop ".narinfo"
524 (if len
525 (get-bytevector-n port len)
526 (read-to-eof port))
527 (cache-narinfo! cache
528 (find (cut string-contains <> hash-part) paths)
529 #f)
530 (update-progress!))
531 #f)
532 (else ; transient failure
533 (if len
534 (get-bytevector-n port len)
535 (read-to-eof port))
536 #f))))
538 (and (string=? (cache-store-directory cache) (%store-prefix))
539 (let ((uri (string->uri url)))
540 (case (and=> uri uri-scheme)
541 ((http)
542 (let ((requests (map (cut narinfo-request url <>) paths)))
543 (update-progress!)
544 (let ((result (http-multiple-get url requests
545 handle-narinfo-response)))
546 (newline (current-error-port))
547 result)))
548 ((file #f)
549 (let* ((base (string-append (uri-path uri) "/"))
550 (files (map (compose (cut string-append base <> ".narinfo")
551 store-path-hash-part)
552 paths)))
553 (filter-map (cut narinfo-from-file <> url) files)))
554 (else
555 (leave (_ "~s: unsupported server URI scheme~%")
556 (if uri (uri-scheme uri) url)))))))
558 (define (lookup-narinfos cache paths)
559 "Return the narinfos for PATHS, invoking the server at CACHE when no
560 information is available locally."
561 (let-values (((cached missing)
562 (fold2 (lambda (path cached missing)
563 (let-values (((valid? value)
564 (cached-narinfo path)))
565 (if valid?
566 (values (cons value cached) missing)
567 (values cached (cons path missing)))))
568 '()
569 '()
570 paths)))
571 (if (null? missing)
572 cached
573 (let* ((cache (force cache))
574 (missing (if cache
575 (fetch-narinfos cache missing)
576 '())))
577 (append cached missing)))))
579 (define (lookup-narinfo cache path)
580 "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
581 found."
582 (match (lookup-narinfos cache (list path))
583 ((answer) answer)))
585 (define (remove-expired-cached-narinfos)
586 "Remove expired narinfo entries from the cache. The sole purpose of this
587 function is to make sure `%narinfo-cache-directory' doesn't grow
588 indefinitely."
589 (define now
590 (current-time time-monotonic))
592 (define (expired? file)
593 (catch 'system-error
594 (lambda ()
595 (call-with-input-file file
596 (lambda (port)
597 (match (read port)
598 (('narinfo ('version 1) ('cache-uri _) ('date date)
599 ('value #f))
600 (obsolete? date now %narinfo-negative-ttl))
601 (('narinfo ('version 1) ('cache-uri _) ('date date)
602 ('value _))
603 (obsolete? date now %narinfo-ttl))
604 (_ #t)))))
605 (lambda args
606 ;; FILE may have been deleted.
607 #t)))
609 (for-each (lambda (file)
610 (let ((file (string-append %narinfo-cache-directory
611 "/" file)))
612 (when (expired? file)
613 ;; Wrap in `false-if-exception' because FILE might have been
614 ;; deleted in the meantime (TOCTTOU).
615 (false-if-exception (delete-file file)))))
616 (scandir %narinfo-cache-directory
617 (lambda (file)
618 (= (string-length file) 32)))))
620 (define (maybe-remove-expired-cached-narinfo)
621 "Remove expired narinfo entries from the cache if deemed necessary."
622 (define now
623 (current-time time-monotonic))
625 (define expiry-file
626 (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
628 (define last-expiry-date
629 (or (false-if-exception
630 (call-with-input-file expiry-file read))
631 0))
633 (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
634 (remove-expired-cached-narinfos)
635 (call-with-output-file expiry-file
636 (cute write (time-second now) <>))))
638 (define (progress-report-port report-progress port)
639 "Return a port that calls REPORT-PROGRESS every time something is read from
640 PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
641 `progress-proc'."
642 (define total 0)
643 (define (read! bv start count)
644 (let ((n (match (get-bytevector-n! port bv start count)
645 ((? eof-object?) 0)
646 (x x))))
647 (set! total (+ total n))
648 (report-progress total (const n))
649 ;; XXX: We're not in control, so we always return anyway.
650 n))
652 ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done,
653 ;; don't pretend to report any progress in that case.
654 (if (guile-version>? "2.0.5")
655 (make-custom-binary-input-port "progress-port-proc"
656 read! #f #f
657 (cut close-port port))
658 (begin
659 (format (current-error-port) (_ "Downloading, please wait...~%"))
660 (format (current-error-port)
661 (_ "(Please consider upgrading Guile to get proper progress report.)~%"))
662 port)))
664 (define-syntax with-networking
665 (syntax-rules ()
666 "Catch DNS lookup errors and gracefully exit."
667 ;; Note: no attempt is made to catch other networking errors, because DNS
668 ;; lookup errors are typically the first one, and because other errors are
669 ;; a subset of `system-error', which is harder to filter.
670 ((_ exp ...)
671 (catch 'getaddrinfo-error
672 (lambda () exp ...)
673 (lambda (key error)
674 (leave (_ "host name lookup error: ~a~%")
675 (gai-strerror error)))))))
677 \f
678 ;;;
679 ;;; Help.
680 ;;;
682 (define (show-help)
683 (display (_ "Usage: guix substitute [OPTION]...
684 Internal tool to substitute a pre-built binary to a local build.\n"))
685 (display (_ "
686 --query report on the availability of substitutes for the
687 store file names passed on the standard input"))
688 (display (_ "
689 --substitute STORE-FILE DESTINATION
690 download STORE-FILE and store it as a Nar in file
691 DESTINATION"))
692 (newline)
693 (display (_ "
694 -h, --help display this help and exit"))
695 (display (_ "
696 -V, --version display version information and exit"))
697 (newline)
698 (show-bug-report-information))
701 \f
702 ;;;
703 ;;; Entry point.
704 ;;;
706 (define (check-acl-initialized)
707 "Warn if the ACL is uninitialized."
708 (define (singleton? acl)
709 ;; True if ACL contains just the user's public key.
710 (and (file-exists? %public-key-file)
711 (let ((key (call-with-input-file %public-key-file
712 (compose string->canonical-sexp
713 get-string-all))))
714 (match acl
715 ((thing)
716 (equal? (canonical-sexp->string thing)
717 (canonical-sexp->string key)))
718 (_
719 #f)))))
721 (let ((acl (acl->public-keys (current-acl))))
722 (when (or (null? acl) (singleton? acl))
723 (warning (_ "ACL for archive imports seems to be uninitialized, \
724 substitutes may be unavailable\n")))))
726 (define (daemon-options)
727 "Return a list of name/value pairs denoting build daemon options."
728 (define %not-newline
729 (char-set-complement (char-set #\newline)))
731 (match (getenv "_NIX_OPTIONS")
732 (#f ;should not happen when called by the daemon
733 '())
734 (newline-separated
735 ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n".
736 (filter-map (lambda (option=value)
737 (match (string-index option=value #\=)
738 (#f ;invalid option setting
739 #f)
740 (equal-sign
741 (cons (string-take option=value equal-sign)
742 (string-drop option=value (+ 1 equal-sign))))))
743 (string-tokenize newline-separated %not-newline)))))
745 (define (find-daemon-option option)
746 "Return the value of build daemon option OPTION, or #f if it could not be
747 found."
748 (assoc-ref (daemon-options) option))
750 (define %cache-url
751 (match (and=> ;; TODO: Uncomment the following lines when multiple
752 ;; substitute sources are supported.
753 ;; (find-daemon-option "untrusted-substitute-urls") ;client
754 ;; " "
755 (find-daemon-option "substitute-urls") ;admin
756 string-tokenize)
757 ((url)
758 url)
759 ((head tail ..1)
760 ;; Currently we don't handle multiple substitute URLs.
761 (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
762 tail)
763 head)
764 (#f
765 ;; This can only happen when this script is not invoked by the
766 ;; daemon.
767 "http://hydra.gnu.org")))
769 (define (guix-substitute . args)
770 "Implement the build daemon's substituter protocol."
771 (mkdir-p %narinfo-cache-directory)
772 (maybe-remove-expired-cached-narinfo)
773 (check-acl-initialized)
775 ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
776 ;; when we know we cannot substitute, but we must emit a newline on stdout
777 ;; when everything is alright.
778 (let ((uri (string->uri %cache-url)))
779 (case (uri-scheme uri)
780 ((http)
781 ;; Exit gracefully if there's no network access.
782 (let ((host (uri-host uri)))
783 (catch 'getaddrinfo-error
784 (lambda ()
785 (getaddrinfo host))
786 (lambda (key error)
787 (warning (_ "failed to look up host '~a' (~a), \
788 substituter disabled~%")
789 host (gai-strerror error))
790 (exit 0)))))
791 (else #t)))
793 ;; Say hello (see above.)
794 (newline)
795 (force-output (current-output-port))
797 (with-networking
798 (with-error-handling ; for signature errors
799 (match args
800 (("--query")
801 (let ((cache (open-cache* %cache-url))
802 (acl (current-acl)))
803 (define (valid? obj)
804 (and (narinfo? obj) (valid-narinfo? obj acl)))
806 (let loop ((command (read-line)))
807 (or (eof-object? command)
808 (begin
809 (match (string-tokenize command)
810 (("have" paths ..1)
811 ;; Return the subset of PATHS available in CACHE.
812 (let ((substitutable
813 (if cache
814 (lookup-narinfos cache paths)
815 '())))
816 (for-each (lambda (narinfo)
817 (format #t "~a~%" (narinfo-path narinfo)))
818 (filter valid? substitutable))
819 (newline)))
820 (("info" paths ..1)
821 ;; Reply info about PATHS if it's in CACHE.
822 (let ((substitutable
823 (if cache
824 (lookup-narinfos cache paths)
825 '())))
826 (for-each (lambda (narinfo)
827 (format #t "~a\n~a\n~a\n"
828 (narinfo-path narinfo)
829 (or (and=> (narinfo-deriver narinfo)
830 (cute string-append
831 (%store-prefix) "/"
832 <>))
833 "")
834 (length (narinfo-references narinfo)))
835 (for-each (cute format #t "~a/~a~%"
836 (%store-prefix) <>)
837 (narinfo-references narinfo))
838 (format #t "~a\n~a\n"
839 (or (narinfo-file-size narinfo) 0)
840 (or (narinfo-size narinfo) 0)))
841 (filter valid? substitutable))
842 (newline)))
843 (wtf
844 (error "unknown `--query' command" wtf)))
845 (loop (read-line)))))))
846 (("--substitute" store-path destination)
847 ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
848 (let* ((cache (open-cache* %cache-url))
849 (narinfo (lookup-narinfo cache store-path))
850 (uri (narinfo-uri narinfo)))
851 ;; Make sure it is signed and everything.
852 (assert-valid-narinfo narinfo)
854 ;; Tell the daemon what the expected hash of the Nar itself is.
855 (format #t "~a~%" (narinfo-hash narinfo))
857 (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
858 store-path
860 ;; Use the Nar size as an estimate of the installed size.
861 (narinfo-size narinfo)
862 (and=> (narinfo-size narinfo)
863 (cute / <> (expt 2. 20))))
864 (let*-values (((raw download-size)
865 ;; Note that Hydra currently generates Nars on the fly
866 ;; and doesn't specify a Content-Length, so
867 ;; DOWNLOAD-SIZE is #f in practice.
868 (fetch uri #:buffered? #f #:timeout? #f))
869 ((progress)
870 (let* ((comp (narinfo-compression narinfo))
871 (dl-size (or download-size
872 (and (equal? comp "none")
873 (narinfo-size narinfo))))
874 (progress (progress-proc (uri-abbreviation uri)
875 dl-size
876 (current-error-port))))
877 (progress-report-port progress raw)))
878 ((input pids)
879 (decompressed-port (and=> (narinfo-compression narinfo)
880 string->symbol)
881 progress)))
882 ;; Unpack the Nar at INPUT into DESTINATION.
883 (restore-file input destination)
885 ;; Skip a line after what 'progress-proc' printed.
886 (newline (current-error-port))
888 (every (compose zero? cdr waitpid) pids))))
889 (("--version")
890 (show-version-and-exit "guix substitute"))
891 (("--help")
892 (show-help))
893 (opts
894 (leave (_ "~a: unrecognized options~%") opts))))))
897 ;;; Local Variables:
898 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
899 ;;; End:
901 ;;; substitute.scm ends here