From 2c74fde00e4e721c6a73646935ab0cfe19dd9188 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2015 10:34:27 +0100 Subject: Rename 'guix substitute-binary' to 'guix substitute'. * guix/scripts/substitute-binary.scm: Rename to... * guix/scripts/substitute.scm: ... this. Adjust module name, entry point, comments, and help string accordingly. * nix/scripts/substitute-binary.in: Rename to... * nix/scripts/substitute.in: ... this. * pre-inst-env.in (NIX_SUBSTITUTERS): Adjust accordingly. * tests/substitute-binary.scm: Rename to... * tests/substitute.scm: ... this. Adjust references to (guix scripts substitute) accordingly. * guix/ui.scm (show-guix-help)[internal?]: Change "substitute-binary" to "substitute". * Makefile.am (MODULES, SCM_TESTS): Adjust to file renames. * daemon.am (nodist_pkglibexec_SCRIPTS): Likewise. * config-daemon.ac: Likewise. * guix/tests.scm (call-with-derivation-narinfo): Adjust comments and docstring. --- .gitignore | 2 +- Makefile.am | 4 +- config-daemon.ac | 4 +- daemon.am | 2 +- guix/scripts/substitute-binary.scm | 896 ------------------------------------- guix/scripts/substitute.scm | 896 +++++++++++++++++++++++++++++++++++++ guix/tests.scm | 4 +- guix/ui.scm | 2 +- nix/scripts/substitute-binary.in | 11 - nix/scripts/substitute.in | 11 + pre-inst-env.in | 2 +- tests/store.scm | 10 +- tests/substitute-binary.scm | 284 ------------ tests/substitute.scm | 284 ++++++++++++ 14 files changed, 1206 insertions(+), 1206 deletions(-) delete mode 100755 guix/scripts/substitute-binary.scm create mode 100755 guix/scripts/substitute.scm delete mode 100644 nix/scripts/substitute-binary.in create mode 100644 nix/scripts/substitute.in delete mode 100644 tests/substitute-binary.scm create mode 100644 tests/substitute.scm diff --git a/.gitignore b/.gitignore index 3ec36366e3..eaa7dbd51a 100644 --- a/.gitignore +++ b/.gitignore @@ -96,7 +96,7 @@ stamp-h[0-9] /doc/guix.tp /doc/guix.vr /doc/guix.vrs -/nix/scripts/substitute-binary +/nix/scripts/substitute /doc/images/bootstrap-graph.png /doc/images/bootstrap-graph.eps /guix-register diff --git a/Makefile.am b/Makefile.am index 882ab8e27b..4a1f8d0a88 100644 --- a/Makefile.am +++ b/Makefile.am @@ -96,7 +96,7 @@ MODULES = \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pull.scm \ - guix/scripts/substitute-binary.scm \ + guix/scripts/substitute.scm \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ guix/scripts/system.scm \ @@ -162,7 +162,7 @@ SCM_TESTS = \ tests/pk-crypto.scm \ tests/pki.scm \ tests/sets.scm \ - tests/substitute-binary.scm \ + tests/substitute.scm \ tests/builders.scm \ tests/derivations.scm \ tests/ui.scm \ diff --git a/config-daemon.ac b/config-daemon.ac index 5f83d45a4c..fb80c754c9 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -133,8 +133,8 @@ if test "x$guix_build_daemon" = "xyes"; then AC_CONFIG_FILES([nix/scripts/list-runtime-roots], [chmod +x nix/scripts/list-runtime-roots]) - AC_CONFIG_FILES([nix/scripts/substitute-binary], - [chmod +x nix/scripts/substitute-binary]) + AC_CONFIG_FILES([nix/scripts/substitute], + [chmod +x nix/scripts/substitute]) AC_CONFIG_FILES([nix/scripts/guix-authenticate], [chmod +x nix/scripts/guix-authenticate]) AC_CONFIG_FILES([nix/scripts/offload], diff --git a/daemon.am b/daemon.am index 5963606861..9d6516ae6c 100644 --- a/daemon.am +++ b/daemon.am @@ -165,7 +165,7 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql nodist_pkglibexec_SCRIPTS = \ nix/scripts/list-runtime-roots \ - nix/scripts/substitute-binary + nix/scripts/substitute if BUILD_DAEMON_OFFLOAD diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm deleted file mode 100755 index e797c6d40b..0000000000 --- a/guix/scripts/substitute-binary.scm +++ /dev/null @@ -1,896 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès -;;; Copyright © 2014 Nikita Karetnikov -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix scripts substitute-binary) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (guix config) - #:use-module (guix records) - #:use-module (guix serialization) - #:use-module (guix hash) - #:use-module (guix base64) - #:use-module (guix pk-crypto) - #:use-module (guix pki) - #:use-module ((guix build utils) #:select (mkdir-p dump-port)) - #:use-module ((guix build download) - #:select (progress-proc uri-abbreviation)) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (ice-9 ftw) - #:use-module (ice-9 binary-ports) - #:use-module (rnrs io ports) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) - #:use-module (web uri) - #:use-module (web request) - #:use-module (web response) - #:use-module (guix http-client) - #:export (narinfo-signature->canonical-sexp - read-narinfo - write-narinfo - guix-substitute-binary)) - -;;; Comment: -;;; -;;; This is the "binary substituter". It is invoked by the daemon do check -;;; for the existence of available "substitutes" (pre-built binaries), and to -;;; actually use them as a substitute to building things locally. -;;; -;;; If possible, substitute a binary for the requested store path, using a Nix -;;; "binary cache". This program implements the Nix "substituter" protocol. -;;; -;;; Code: - -(define %narinfo-cache-directory - ;; A local cache of narinfos, to avoid going to the network. - (or (and=> (getenv "XDG_CACHE_HOME") - (cut string-append <> "/guix/substitute-binary")) - (string-append %state-directory "/substitute-binary/cache"))) - -(define %allow-unauthenticated-substitutes? - ;; Whether to allow unchecked substitutes. This is useful for testing - ;; purposes, and should be avoided otherwise. - (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") - (cut string-ci=? <> "yes")) - (begin - (warning (_ "authentication and authorization of substitutes \ -disabled!~%")) - #t))) - -(define %narinfo-ttl - ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. - (* 24 3600)) - -(define %narinfo-negative-ttl - ;; Likewise, but for negative lookups---i.e., cached lookup failures. - (* 3 3600)) - -(define %narinfo-expired-cache-entry-removal-delay - ;; How often we want to remove files corresponding to expired cache entries. - (* 7 24 3600)) - -(define fields->alist - ;; The narinfo format is really just like recutils. - recutils->alist) - -(define %fetch-timeout - ;; Number of seconds after which networking is considered "slow". - 5) - -(define %random-state - (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) - -(define-syntax-rule (with-timeout duration handler body ...) - "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY -again." - (begin - (sigaction SIGALRM - (lambda (signum) - (sigaction SIGALRM SIG_DFL) - handler)) - (alarm duration) - (call-with-values - (lambda () - (let try () - (catch 'system-error - (lambda () - body ...) - (lambda args - ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR - ;; because of the bug at - ;; . - ;; When that happens, try again. Note: SA_RESTART cannot be - ;; used because of . - (if (= EINTR (system-error-errno args)) - (begin - ;; Wait a little to avoid bursts. - (usleep (random 3000000 %random-state)) - (try)) - (apply throw args)))))) - (lambda result - (alarm 0) - (sigaction SIGALRM SIG_DFL) - (apply values result))))) - -(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) - "Return a binary input port to URI and the number of bytes it's expected to -provide. If QUIET-404? is true, HTTP 404 error conditions are passed through -to the caller without emitting an error message." - (case (uri-scheme uri) - ((file) - (let ((port (open-file (uri-path uri) - (if buffered? "rb" "r0b")))) - (values port (stat:size (stat port))))) - ((http) - (guard (c ((http-get-error? c) - (let ((code (http-get-error-code c))) - (if (and (= code 404) quiet-404?) - (raise c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - code (http-get-error-reason c)))))) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) - %fetch-timeout - 0) - (begin - (warning (_ "while fetching ~a: server is somewhat slow~%") - (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) - - ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, - ;; and thus PORT had to be closed and re-opened. This is not the - ;; case afterward. - (unless (or (guile-version>? "2.0.9") - (version>? (version) "2.0.9.39")) - (when port - (close-port port)))) - (begin - (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) - (http-fetch uri #:text? #f #:port port)))))))) - -(define-record-type - (%make-cache url store-directory wants-mass-query?) - cache? - (url cache-url) - (store-directory cache-store-directory) - (wants-mass-query? cache-wants-mass-query?)) - -(define (open-cache url) - "Open the binary cache at URL. Return a object on success, or #f on -failure." - (define (download-cache-info url) - ;; Download the `nix-cache-info' from URL, and return its contents as an - ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) - - (and=> (download-cache-info (string-append url "/nix-cache-info")) - (lambda (properties) - (alist->record properties - (cut %make-cache url <...>) - '("StoreDir" "WantMassQuery"))))) - -(define-syntax-rule (open-cache* url) - "Delayed variant of 'open-cache' that also lets the user know that they're -gonna have to wait." - (delay (begin - (format (current-error-port) - (_ "updating list of substitutes from '~a'...\r") - url) - (open-cache url)))) - -(define-record-type - (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size - references deriver system signature contents) - narinfo? - (path narinfo-path) - (uri narinfo-uri) - (uri-base narinfo-uri-base) ; URI of the cache it originates from - (compression narinfo-compression) - (file-hash narinfo-file-hash) - (file-size narinfo-file-size) - (nar-hash narinfo-hash) - (nar-size narinfo-size) - (references narinfo-references) - (deriver narinfo-deriver) - (system narinfo-system) - (signature narinfo-signature) ; canonical sexp - ;; The original contents of a narinfo file. This field is needed because we - ;; want to preserve the exact textual representation for verification purposes. - ;; See - ;; for more information. - (contents narinfo-contents)) - -(define (narinfo-signature->canonical-sexp str) - "Return the value of a narinfo's 'Signature' field as a canonical sexp." - (match (string-split str #\;) - ((version _ sig) - (let ((maybe-number (string->number version))) - (cond ((not (number? maybe-number)) - (leave (_ "signature version must be a number: ~s~%") - version)) - ;; Currently, there are no other versions. - ((not (= 1 maybe-number)) - (leave (_ "unsupported signature version: ~a~%") - maybe-number)) - (else - (let ((signature (utf8->string (base64-decode sig)))) - (catch 'gcry-error - (lambda () - (string->canonical-sexp signature)) - (lambda (key proc err) - (leave (_ "signature is not a valid \ -s-expression: ~s~%") - signature)))))))) - (x - (leave (_ "invalid format of the signature field: ~a~%") x)))) - -(define (narinfo-maker str cache-url) - "Return a narinfo constructor for narinfos originating from CACHE-URL. STR -must contain the original contents of a narinfo file." - (lambda (path url compression file-hash file-size nar-hash nar-size - references deriver system signature) - "Return a new object." - (%make-narinfo path - ;; Handle the case where URL is a relative URL. - (or (string->uri url) - (string->uri (string-append cache-url "/" url))) - cache-url - - compression file-hash - (and=> file-size string->number) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system - (false-if-exception - (and=> signature narinfo-signature->canonical-sexp)) - str))) - -(define* (assert-valid-signature narinfo signature hash - #:optional (acl (current-acl))) - "Bail out if SIGNATURE, a canonical sexp representing the signature of -NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." - (let ((uri (uri->string (narinfo-uri narinfo)))) - (signature-case (signature hash acl) - (valid-signature #t) - (invalid-signature - (leave (_ "invalid signature for '~a'~%") uri)) - (hash-mismatch - (leave (_ "hash mismatch for '~a'~%") uri)) - (unauthorized-key - (leave (_ "'~a' is signed with an unauthorized key~%") uri)) - (corrupt-signature - (leave (_ "signature on '~a' is corrupt~%") uri))))) - -(define* (read-narinfo port #:optional url - #:key size) - "Read a narinfo from PORT. If URL is true, it must be a string used to -build full URIs from relative URIs found while reading PORT. When SIZE is -true, read at most SIZE bytes from PORT; otherwise, read as much as possible. - -No authentication and authorization checks are performed here!" - (let ((str (utf8->string (if size - (get-bytevector-n port size) - (get-bytevector-all port))))) - (alist->record (call-with-input-string str fields->alist) - (narinfo-maker str url) - '("StorePath" "URL" "Compression" - "FileHash" "FileSize" "NarHash" "NarSize" - "References" "Deriver" "System" - "Signature")))) - -(define (narinfo-sha256 narinfo) - "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a -'Signature' field." - (let ((contents (narinfo-contents narinfo))) - (match (string-contains contents "Signature:") - (#f #f) - (index - (let ((above-signature (string-take contents index))) - (sha256 (string->utf8 above-signature))))))) - -(define* (assert-valid-narinfo narinfo - #:optional (acl (current-acl)) - #:key (verbose? #t)) - "Raise an exception if NARINFO lacks a signature, has an invalid signature, -or is signed by an unauthorized key." - (let ((hash (narinfo-sha256 narinfo))) - (if (not hash) - (if %allow-unauthenticated-substitutes? - narinfo - (leave (_ "substitute at '~a' lacks a signature~%") - (uri->string (narinfo-uri narinfo)))) - (let ((signature (narinfo-signature narinfo))) - (unless %allow-unauthenticated-substitutes? - (assert-valid-signature narinfo signature hash acl) - (when verbose? - (format (current-error-port) - "found valid signature for '~a', from '~a'~%" - (narinfo-path narinfo) - (uri->string (narinfo-uri narinfo))))) - narinfo)))) - -(define* (valid-narinfo? narinfo #:optional (acl (current-acl))) - "Return #t if NARINFO's signature is not valid." - (or %allow-unauthenticated-substitutes? - (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo))) - (and hash signature - (signature-case (signature hash acl) - (valid-signature #t) - (else #f)))))) - -(define (write-narinfo narinfo port) - "Write NARINFO to PORT." - (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) - -(define (narinfo->string narinfo) - "Return the external representation of NARINFO." - (call-with-output-string (cut write-narinfo narinfo <>))) - -(define (string->narinfo str cache-uri) - "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of -the cache STR originates form." - (call-with-input-string str (cut read-narinfo <> cache-uri))) - -(define (obsolete? date now ttl) - "Return #t if DATE is obsolete compared to NOW + TTL seconds." - (time>? (subtract-duration now (make-time time-duration 0 ttl)) - (make-time time-monotonic 0 date))) - - -(define (narinfo-cache-file path) - "Return the name of the local file that contains an entry for PATH." - (string-append %narinfo-cache-directory "/" - (store-path-hash-part path))) - -(define (cached-narinfo path) - "Check locally if we have valid info about PATH. Return two values: a -Boolean indicating whether we have valid cached info, and that info, which may -be either #f (when PATH is unavailable) or the narinfo for PATH." - (define now - (current-time time-monotonic)) - - (define cache-file - (narinfo-cache-file path)) - - (catch 'system-error - (lambda () - (call-with-input-file cache-file - (lambda (p) - (match (read p) - (('narinfo ('version 1) - ('cache-uri cache-uri) - ('date date) ('value #f)) - ;; A cached negative lookup. - (if (obsolete? date now %narinfo-negative-ttl) - (values #f #f) - (values #t #f))) - (('narinfo ('version 1) - ('cache-uri cache-uri) - ('date date) ('value value)) - ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) - (values #f #f) - (values #t (string->narinfo value cache-uri)))) - (('narinfo ('version v) _ ...) - (values #f #f)))))) - (lambda _ - (values #f #f)))) - -(define (cache-narinfo! cache path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may -be #f, in which case it indicates that PATH is unavailable at CACHE." - (define now - (current-time time-monotonic)) - - (define (cache-entry cache-uri narinfo) - `(narinfo (version 1) - (cache-uri ,cache-uri) - (date ,(time-second now)) - (value ,(and=> narinfo narinfo->string)))) - - (with-atomic-file-output (narinfo-cache-file path) - (lambda (out) - (write (cache-entry (cache-url cache) narinfo) out))) - narinfo) - -(define (narinfo-request cache-url path) - "Return an HTTP request for the narinfo of PATH at CACHE-URL." - (let ((url (string-append cache-url "/" (store-path-hash-part path) - ".narinfo"))) - (build-request (string->uri url) #:method 'GET))) - -(define (http-multiple-get base-url requests proc) - "Send all of REQUESTS to the server at BASE-URL. Call PROC for each -response, passing it the request object, the response, and a port from which -to read the response body. Return the list of results." - (let connect ((requests requests) - (result '())) - ;; (format (current-error-port) "connecting (~a requests left)..." - ;; (length requests)) - (let ((p (open-socket-for-uri base-url))) - ;; Send all of REQUESTS in a row. - (setvbuf p _IOFBF (expt 2 16)) - (for-each (cut write-request <> p) requests) - (force-output p) - - ;; Now start processing responses. - (let loop ((requests requests) - (result result)) - (match requests - (() - (reverse result)) - ((head tail ...) - (let* ((resp (read-response p)) - (body (response-body-port resp))) - ;; The server can choose to stop responding at any time, in which - ;; case we have to try again. Check whether that is the case. - (match (assq 'connection (response-headers resp)) - (('connection 'close) - (connect requests result)) ;try again - (_ - (loop tail ;keep going - (cons (proc head resp body) result))))))))))) - -(define (read-to-eof port) - "Read from PORT until EOF is reached. The data are discarded." - (dump-port port (%make-void-port "w"))) - -(define (narinfo-from-file file url) - "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f -if file doesn't exist, and the narinfo otherwise." - (catch 'system-error - (lambda () - (call-with-input-file file - (cut read-narinfo <> url))) - (lambda args - (if (= ENOENT (system-error-errno args)) - #f - (apply throw args))))) - -(define (fetch-narinfos cache paths) - "Retrieve all the narinfos for PATHS from CACHE and return them." - (define url - (cache-url cache)) - - (define update-progress! - (let ((done 0)) - (lambda () - (display #\cr (current-error-port)) - (force-output (current-error-port)) - (format (current-error-port) - (_ "updating list of substitutes from '~a'... ~5,1f%") - url (* 100. (/ done (length paths)))) - (set! done (+ 1 done))))) - - (define (handle-narinfo-response request response port) - (let ((len (response-content-length response))) - ;; Make sure to read no more than LEN bytes since subsequent bytes may - ;; belong to the next response. - (case (response-code response) - ((200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! cache (narinfo-path narinfo) narinfo) - (update-progress!) - narinfo)) - ((404) ; failure - (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (cache-narinfo! cache - (find (cut string-contains <> hash-part) paths) - #f) - (update-progress!)) - #f) - (else ; transient failure - (if len - (get-bytevector-n port len) - (read-to-eof port)) - #f)))) - - (and (string=? (cache-store-directory cache) (%store-prefix)) - (let ((uri (string->uri url))) - (case (and=> uri uri-scheme) - ((http) - (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - (let ((result (http-multiple-get url requests - handle-narinfo-response))) - (newline (current-error-port)) - result))) - ((file #f) - (let* ((base (string-append (uri-path uri) "/")) - (files (map (compose (cut string-append base <> ".narinfo") - store-path-hash-part) - paths))) - (filter-map (cut narinfo-from-file <> url) files))) - (else - (leave (_ "~s: unsupported server URI scheme~%") - (if uri (uri-scheme uri) url))))))) - -(define (lookup-narinfos cache paths) - "Return the narinfos for PATHS, invoking the server at CACHE when no -information is available locally." - (let-values (((cached missing) - (fold2 (lambda (path cached missing) - (let-values (((valid? value) - (cached-narinfo path))) - (if valid? - (values (cons value cached) missing) - (values cached (cons path missing))))) - '() - '() - paths))) - (if (null? missing) - cached - (let* ((cache (force cache)) - (missing (if cache - (fetch-narinfos cache missing) - '()))) - (append cached missing))))) - -(define (lookup-narinfo cache path) - "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was -found." - (match (lookup-narinfos cache (list path)) - ((answer) answer))) - -(define (remove-expired-cached-narinfos) - "Remove expired narinfo entries from the cache. The sole purpose of this -function is to make sure `%narinfo-cache-directory' doesn't grow -indefinitely." - (define now - (current-time time-monotonic)) - - (define (expired? file) - (catch 'system-error - (lambda () - (call-with-input-file file - (lambda (port) - (match (read port) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value #f)) - (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value _)) - (obsolete? date now %narinfo-ttl)) - (_ #t))))) - (lambda args - ;; FILE may have been deleted. - #t))) - - (for-each (lambda (file) - (let ((file (string-append %narinfo-cache-directory - "/" file))) - (when (expired? file) - ;; Wrap in `false-if-exception' because FILE might have been - ;; deleted in the meantime (TOCTTOU). - (false-if-exception (delete-file file))))) - (scandir %narinfo-cache-directory - (lambda (file) - (= (string-length file) 32))))) - -(define (maybe-remove-expired-cached-narinfo) - "Remove expired narinfo entries from the cache if deemed necessary." - (define now - (current-time time-monotonic)) - - (define expiry-file - (string-append %narinfo-cache-directory "/last-expiry-cleanup")) - - (define last-expiry-date - (or (false-if-exception - (call-with-input-file expiry-file read)) - 0)) - - (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay) - (remove-expired-cached-narinfos) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) - -(define (progress-report-port report-progress port) - "Return a port that calls REPORT-PROGRESS every time something is read from -PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by -`progress-proc'." - (define total 0) - (define (read! bv start count) - (let ((n (match (get-bytevector-n! port bv start count) - ((? eof-object?) 0) - (x x)))) - (set! total (+ total n)) - (report-progress total (const n)) - ;; XXX: We're not in control, so we always return anyway. - n)) - - ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done, - ;; don't pretend to report any progress in that case. - (if (guile-version>? "2.0.5") - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-port port)) - (begin - (format (current-error-port) (_ "Downloading, please wait...~%")) - (format (current-error-port) - (_ "(Please consider upgrading Guile to get proper progress report.)~%")) - port))) - -(define-syntax with-networking - (syntax-rules () - "Catch DNS lookup errors and gracefully exit." - ;; Note: no attempt is made to catch other networking errors, because DNS - ;; lookup errors are typically the first one, and because other errors are - ;; a subset of `system-error', which is harder to filter. - ((_ exp ...) - (catch 'getaddrinfo-error - (lambda () exp ...) - (lambda (key error) - (leave (_ "host name lookup error: ~a~%") - (gai-strerror error))))))) - - -;;; -;;; Help. -;;; - -(define (show-help) - (display (_ "Usage: guix substitute-binary [OPTION]... -Internal tool to substitute a pre-built binary to a local build.\n")) - (display (_ " - --query report on the availability of substitutes for the - store file names passed on the standard input")) - (display (_ " - --substitute STORE-FILE DESTINATION - download STORE-FILE and store it as a Nar in file - DESTINATION")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - - - -;;; -;;; Entry point. -;;; - -(define (check-acl-initialized) - "Warn if the ACL is uninitialized." - (define (singleton? acl) - ;; True if ACL contains just the user's public key. - (and (file-exists? %public-key-file) - (let ((key (call-with-input-file %public-key-file - (compose string->canonical-sexp - get-string-all)))) - (match acl - ((thing) - (equal? (canonical-sexp->string thing) - (canonical-sexp->string key))) - (_ - #f))))) - - (let ((acl (acl->public-keys (current-acl)))) - (when (or (null? acl) (singleton? acl)) - (warning (_ "ACL for archive imports seems to be uninitialized, \ -substitutes may be unavailable\n"))))) - -(define (daemon-options) - "Return a list of name/value pairs denoting build daemon options." - (define %not-newline - (char-set-complement (char-set #\newline))) - - (match (getenv "_NIX_OPTIONS") - (#f ;should not happen when called by the daemon - '()) - (newline-separated - ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n". - (filter-map (lambda (option=value) - (match (string-index option=value #\=) - (#f ;invalid option setting - #f) - (equal-sign - (cons (string-take option=value equal-sign) - (string-drop option=value (+ 1 equal-sign)))))) - (string-tokenize newline-separated %not-newline))))) - -(define (find-daemon-option option) - "Return the value of build daemon option OPTION, or #f if it could not be -found." - (assoc-ref (daemon-options) option)) - -(define %cache-url - (match (and=> ;; TODO: Uncomment the following lines when multiple - ;; substitute sources are supported. - ;; (find-daemon-option "untrusted-substitute-urls") ;client - ;; " " - (find-daemon-option "substitute-urls") ;admin - string-tokenize) - ((url) - url) - ((head tail ..1) - ;; Currently we don't handle multiple substitute URLs. - (warning (_ "these substitute URLs will not be used:~{ ~a~}~%") - tail) - head) - (#f - ;; This can only happen when this script is not invoked by the - ;; daemon. - "http://hydra.gnu.org"))) - -(define (guix-substitute-binary . args) - "Implement the build daemon's substituter protocol." - (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cached-narinfo) - (check-acl-initialized) - - ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly - ;; when we know we cannot substitute, but we must emit a newline on stdout - ;; when everything is alright. - (let ((uri (string->uri %cache-url))) - (case (uri-scheme uri) - ((http) - ;; Exit gracefully if there's no network access. - (let ((host (uri-host uri))) - (catch 'getaddrinfo-error - (lambda () - (getaddrinfo host)) - (lambda (key error) - (warning (_ "failed to look up host '~a' (~a), \ -substituter disabled~%") - host (gai-strerror error)) - (exit 0))))) - (else #t))) - - ;; Say hello (see above.) - (newline) - (force-output (current-output-port)) - - (with-networking - (with-error-handling ; for signature errors - (match args - (("--query") - (let ((cache (open-cache* %cache-url)) - (acl (current-acl))) - (define (valid? obj) - (and (narinfo? obj) (valid-narinfo? obj acl))) - - (let loop ((command (read-line))) - (or (eof-object? command) - (begin - (match (string-tokenize command) - (("have" paths ..1) - ;; Return the subset of PATHS available in CACHE. - (let ((substitutable - (if cache - (lookup-narinfos cache paths) - '()))) - (for-each (lambda (narinfo) - (format #t "~a~%" (narinfo-path narinfo))) - (filter valid? substitutable)) - (newline))) - (("info" paths ..1) - ;; Reply info about PATHS if it's in CACHE. - (let ((substitutable - (if cache - (lookup-narinfos cache paths) - '()))) - (for-each (lambda (narinfo) - (format #t "~a\n~a\n~a\n" - (narinfo-path narinfo) - (or (and=> (narinfo-deriver narinfo) - (cute string-append - (%store-prefix) "/" - <>)) - "") - (length (narinfo-references narinfo))) - (for-each (cute format #t "~a/~a~%" - (%store-prefix) <>) - (narinfo-references narinfo)) - (format #t "~a\n~a\n" - (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0))) - (filter valid? substitutable)) - (newline))) - (wtf - (error "unknown `--query' command" wtf))) - (loop (read-line))))))) - (("--substitute" store-path destination) - ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. - (let* ((cache (open-cache* %cache-url)) - (narinfo (lookup-narinfo cache store-path)) - (uri (narinfo-uri narinfo))) - ;; Make sure it is signed and everything. - (assert-valid-narinfo narinfo) - - ;; Tell the daemon what the expected hash of the Nar itself is. - (format #t "~a~%" (narinfo-hash narinfo)) - - (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" - store-path - - ;; Use the Nar size as an estimate of the installed size. - (narinfo-size narinfo) - (and=> (narinfo-size narinfo) - (cute / <> (expt 2. 20)))) - (let*-values (((raw download-size) - ;; Note that Hydra currently generates Nars on the fly - ;; and doesn't specify a Content-Length, so - ;; DOWNLOAD-SIZE is #f in practice. - (fetch uri #:buffered? #f #:timeout? #f)) - ((progress) - (let* ((comp (narinfo-compression narinfo)) - (dl-size (or download-size - (and (equal? comp "none") - (narinfo-size narinfo)))) - (progress (progress-proc (uri-abbreviation uri) - dl-size - (current-error-port)))) - (progress-report-port progress raw))) - ((input pids) - (decompressed-port (and=> (narinfo-compression narinfo) - string->symbol) - progress))) - ;; Unpack the Nar at INPUT into DESTINATION. - (restore-file input destination) - - ;; Skip a line after what 'progress-proc' printed. - (newline (current-error-port)) - - (every (compose zero? cdr waitpid) pids)))) - (("--version") - (show-version-and-exit "guix substitute-binary")) - (("--help") - (show-help)) - (opts - (leave (_ "~a: unrecognized options~%") opts)))))) - - -;;; Local Variables: -;;; eval: (put 'with-timeout 'scheme-indent-function 1) -;;; End: - -;;; substitute-binary.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm new file mode 100755 index 0000000000..e99c29945c --- /dev/null +++ b/guix/scripts/substitute.scm @@ -0,0 +1,896 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2014 Nikita Karetnikov +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts substitute) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix config) + #:use-module (guix records) + #:use-module (guix serialization) + #:use-module (guix hash) + #:use-module (guix base64) + #:use-module (guix pk-crypto) + #:use-module (guix pki) + #:use-module ((guix build utils) #:select (mkdir-p dump-port)) + #:use-module ((guix build download) + #:select (progress-proc uri-abbreviation)) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (guix http-client) + #:export (narinfo-signature->canonical-sexp + read-narinfo + write-narinfo + guix-substitute)) + +;;; Comment: +;;; +;;; This is the "binary substituter". It is invoked by the daemon do check +;;; for the existence of available "substitutes" (pre-built binaries), and to +;;; actually use them as a substitute to building things locally. +;;; +;;; If possible, substitute a binary for the requested store path, using a Nix +;;; "binary cache". This program implements the Nix "substituter" protocol. +;;; +;;; Code: + +(define %narinfo-cache-directory + ;; A local cache of narinfos, to avoid going to the network. + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute-binary")) + (string-append %state-directory "/substitute-binary/cache"))) + +(define %allow-unauthenticated-substitutes? + ;; Whether to allow unchecked substitutes. This is useful for testing + ;; purposes, and should be avoided otherwise. + (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") + (cut string-ci=? <> "yes")) + (begin + (warning (_ "authentication and authorization of substitutes \ +disabled!~%")) + #t))) + +(define %narinfo-ttl + ;; Number of seconds during which cached narinfo lookups are considered + ;; valid. + (* 24 3600)) + +(define %narinfo-negative-ttl + ;; Likewise, but for negative lookups---i.e., cached lookup failures. + (* 3 3600)) + +(define %narinfo-expired-cache-entry-removal-delay + ;; How often we want to remove files corresponding to expired cache entries. + (* 7 24 3600)) + +(define fields->alist + ;; The narinfo format is really just like recutils. + recutils->alist) + +(define %fetch-timeout + ;; Number of seconds after which networking is considered "slow". + 5) + +(define %random-state + (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) + +(define-syntax-rule (with-timeout duration handler body ...) + "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY +again." + (begin + (sigaction SIGALRM + (lambda (signum) + (sigaction SIGALRM SIG_DFL) + handler)) + (alarm duration) + (call-with-values + (lambda () + (let try () + (catch 'system-error + (lambda () + body ...) + (lambda args + ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR + ;; because of the bug at + ;; . + ;; When that happens, try again. Note: SA_RESTART cannot be + ;; used because of . + (if (= EINTR (system-error-errno args)) + (begin + ;; Wait a little to avoid bursts. + (usleep (random 3000000 %random-state)) + (try)) + (apply throw args)))))) + (lambda result + (alarm 0) + (sigaction SIGALRM SIG_DFL) + (apply values result))))) + +(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) + "Return a binary input port to URI and the number of bytes it's expected to +provide. If QUIET-404? is true, HTTP 404 error conditions are passed through +to the caller without emitting an error message." + (case (uri-scheme uri) + ((file) + (let ((port (open-file (uri-path uri) + (if buffered? "rb" "r0b")))) + (values port (stat:size (stat port))))) + ((http) + (guard (c ((http-get-error? c) + (let ((code (http-get-error-code c))) + (if (and (= code 404) quiet-404?) + (raise c) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + code (http-get-error-reason c)))))) + ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So + ;; honor TIMEOUT? to disable the timeout when fetching a nar. + ;; + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (let ((port #f)) + (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + %fetch-timeout + 0) + (begin + (warning (_ "while fetching ~a: server is somewhat slow~%") + (uri->string uri)) + (warning (_ "try `--no-substitutes' if the problem persists~%")) + + ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, + ;; and thus PORT had to be closed and re-opened. This is not the + ;; case afterward. + (unless (or (guile-version>? "2.0.9") + (version>? (version) "2.0.9.39")) + (when port + (close-port port)))) + (begin + (when (or (not port) (port-closed? port)) + (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (http-fetch uri #:text? #f #:port port)))))))) + +(define-record-type + (%make-cache url store-directory wants-mass-query?) + cache? + (url cache-url) + (store-directory cache-store-directory) + (wants-mass-query? cache-wants-mass-query?)) + +(define (open-cache url) + "Open the binary cache at URL. Return a object on success, or #f on +failure." + (define (download-cache-info url) + ;; Download the `nix-cache-info' from URL, and return its contents as an + ;; list of key/value pairs. + (and=> (false-if-exception (fetch (string->uri url))) + fields->alist)) + + (and=> (download-cache-info (string-append url "/nix-cache-info")) + (lambda (properties) + (alist->record properties + (cut %make-cache url <...>) + '("StoreDir" "WantMassQuery"))))) + +(define-syntax-rule (open-cache* url) + "Delayed variant of 'open-cache' that also lets the user know that they're +gonna have to wait." + (delay (begin + (format (current-error-port) + (_ "updating list of substitutes from '~a'...\r") + url) + (open-cache url)))) + +(define-record-type + (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size + references deriver system signature contents) + narinfo? + (path narinfo-path) + (uri narinfo-uri) + (uri-base narinfo-uri-base) ; URI of the cache it originates from + (compression narinfo-compression) + (file-hash narinfo-file-hash) + (file-size narinfo-file-size) + (nar-hash narinfo-hash) + (nar-size narinfo-size) + (references narinfo-references) + (deriver narinfo-deriver) + (system narinfo-system) + (signature narinfo-signature) ; canonical sexp + ;; The original contents of a narinfo file. This field is needed because we + ;; want to preserve the exact textual representation for verification purposes. + ;; See + ;; for more information. + (contents narinfo-contents)) + +(define (narinfo-signature->canonical-sexp str) + "Return the value of a narinfo's 'Signature' field as a canonical sexp." + (match (string-split str #\;) + ((version _ sig) + (let ((maybe-number (string->number version))) + (cond ((not (number? maybe-number)) + (leave (_ "signature version must be a number: ~s~%") + version)) + ;; Currently, there are no other versions. + ((not (= 1 maybe-number)) + (leave (_ "unsupported signature version: ~a~%") + maybe-number)) + (else + (let ((signature (utf8->string (base64-decode sig)))) + (catch 'gcry-error + (lambda () + (string->canonical-sexp signature)) + (lambda (key proc err) + (leave (_ "signature is not a valid \ +s-expression: ~s~%") + signature)))))))) + (x + (leave (_ "invalid format of the signature field: ~a~%") x)))) + +(define (narinfo-maker str cache-url) + "Return a narinfo constructor for narinfos originating from CACHE-URL. STR +must contain the original contents of a narinfo file." + (lambda (path url compression file-hash file-size nar-hash nar-size + references deriver system signature) + "Return a new object." + (%make-narinfo path + ;; Handle the case where URL is a relative URL. + (or (string->uri url) + (string->uri (string-append cache-url "/" url))) + cache-url + + compression file-hash + (and=> file-size string->number) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system + (false-if-exception + (and=> signature narinfo-signature->canonical-sexp)) + str))) + +(define* (assert-valid-signature narinfo signature hash + #:optional (acl (current-acl))) + "Bail out if SIGNATURE, a canonical sexp representing the signature of +NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." + (let ((uri (uri->string (narinfo-uri narinfo)))) + (signature-case (signature hash acl) + (valid-signature #t) + (invalid-signature + (leave (_ "invalid signature for '~a'~%") uri)) + (hash-mismatch + (leave (_ "hash mismatch for '~a'~%") uri)) + (unauthorized-key + (leave (_ "'~a' is signed with an unauthorized key~%") uri)) + (corrupt-signature + (leave (_ "signature on '~a' is corrupt~%") uri))))) + +(define* (read-narinfo port #:optional url + #:key size) + "Read a narinfo from PORT. If URL is true, it must be a string used to +build full URIs from relative URIs found while reading PORT. When SIZE is +true, read at most SIZE bytes from PORT; otherwise, read as much as possible. + +No authentication and authorization checks are performed here!" + (let ((str (utf8->string (if size + (get-bytevector-n port size) + (get-bytevector-all port))))) + (alist->record (call-with-input-string str fields->alist) + (narinfo-maker str url) + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System" + "Signature")))) + +(define (narinfo-sha256 narinfo) + "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a +'Signature' field." + (let ((contents (narinfo-contents narinfo))) + (match (string-contains contents "Signature:") + (#f #f) + (index + (let ((above-signature (string-take contents index))) + (sha256 (string->utf8 above-signature))))))) + +(define* (assert-valid-narinfo narinfo + #:optional (acl (current-acl)) + #:key (verbose? #t)) + "Raise an exception if NARINFO lacks a signature, has an invalid signature, +or is signed by an unauthorized key." + (let ((hash (narinfo-sha256 narinfo))) + (if (not hash) + (if %allow-unauthenticated-substitutes? + narinfo + (leave (_ "substitute at '~a' lacks a signature~%") + (uri->string (narinfo-uri narinfo)))) + (let ((signature (narinfo-signature narinfo))) + (unless %allow-unauthenticated-substitutes? + (assert-valid-signature narinfo signature hash acl) + (when verbose? + (format (current-error-port) + "found valid signature for '~a', from '~a'~%" + (narinfo-path narinfo) + (uri->string (narinfo-uri narinfo))))) + narinfo)))) + +(define* (valid-narinfo? narinfo #:optional (acl (current-acl))) + "Return #t if NARINFO's signature is not valid." + (or %allow-unauthenticated-substitutes? + (let ((hash (narinfo-sha256 narinfo)) + (signature (narinfo-signature narinfo))) + (and hash signature + (signature-case (signature hash acl) + (valid-signature #t) + (else #f)))))) + +(define (write-narinfo narinfo port) + "Write NARINFO to PORT." + (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) + +(define (narinfo->string narinfo) + "Return the external representation of NARINFO." + (call-with-output-string (cut write-narinfo narinfo <>))) + +(define (string->narinfo str cache-uri) + "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of +the cache STR originates form." + (call-with-input-string str (cut read-narinfo <> cache-uri))) + +(define (obsolete? date now ttl) + "Return #t if DATE is obsolete compared to NOW + TTL seconds." + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (make-time time-monotonic 0 date))) + + +(define (narinfo-cache-file path) + "Return the name of the local file that contains an entry for PATH." + (string-append %narinfo-cache-directory "/" + (store-path-hash-part path))) + +(define (cached-narinfo path) + "Check locally if we have valid info about PATH. Return two values: a +Boolean indicating whether we have valid cached info, and that info, which may +be either #f (when PATH is unavailable) or the narinfo for PATH." + (define now + (current-time time-monotonic)) + + (define cache-file + (narinfo-cache-file path)) + + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date now %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value value)) + ;; A cached positive lookup + (if (obsolete? date now %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value cache-uri)))) + (('narinfo ('version v) _ ...) + (values #f #f)))))) + (lambda _ + (values #f #f)))) + +(define (cache-narinfo! cache path narinfo) + "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may +be #f, in which case it indicates that PATH is unavailable at CACHE." + (define now + (current-time time-monotonic)) + + (define (cache-entry cache-uri narinfo) + `(narinfo (version 1) + (cache-uri ,cache-uri) + (date ,(time-second now)) + (value ,(and=> narinfo narinfo->string)))) + + (with-atomic-file-output (narinfo-cache-file path) + (lambda (out) + (write (cache-entry (cache-url cache) narinfo) out))) + narinfo) + +(define (narinfo-request cache-url path) + "Return an HTTP request for the narinfo of PATH at CACHE-URL." + (let ((url (string-append cache-url "/" (store-path-hash-part path) + ".narinfo"))) + (build-request (string->uri url) #:method 'GET))) + +(define (http-multiple-get base-url requests proc) + "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +response, passing it the request object, the response, and a port from which +to read the response body. Return the list of results." + (let connect ((requests requests) + (result '())) + ;; (format (current-error-port) "connecting (~a requests left)..." + ;; (length requests)) + (let ((p (open-socket-for-uri base-url))) + ;; Send all of REQUESTS in a row. + (setvbuf p _IOFBF (expt 2 16)) + (for-each (cut write-request <> p) requests) + (force-output p) + + ;; Now start processing responses. + (let loop ((requests requests) + (result result)) + (match requests + (() + (reverse result)) + ((head tail ...) + (let* ((resp (read-response p)) + (body (response-body-port resp))) + ;; The server can choose to stop responding at any time, in which + ;; case we have to try again. Check whether that is the case. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (connect requests result)) ;try again + (_ + (loop tail ;keep going + (cons (proc head resp body) result))))))))))) + +(define (read-to-eof port) + "Read from PORT until EOF is reached. The data are discarded." + (dump-port port (%make-void-port "w"))) + +(define (narinfo-from-file file url) + "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f +if file doesn't exist, and the narinfo otherwise." + (catch 'system-error + (lambda () + (call-with-input-file file + (cut read-narinfo <> url))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (fetch-narinfos cache paths) + "Retrieve all the narinfos for PATHS from CACHE and return them." + (define url + (cache-url cache)) + + (define update-progress! + (let ((done 0)) + (lambda () + (display #\cr (current-error-port)) + (force-output (current-error-port)) + (format (current-error-port) + (_ "updating list of substitutes from '~a'... ~5,1f%") + url (* 100. (/ done (length paths)))) + (set! done (+ 1 done))))) + + (define (handle-narinfo-response request response port) + (let ((len (response-content-length response))) + ;; Make sure to read no more than LEN bytes since subsequent bytes may + ;; belong to the next response. + (case (response-code response) + ((200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (cache-narinfo! cache (narinfo-path narinfo) narinfo) + (update-progress!) + narinfo)) + ((404) ; failure + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! cache + (find (cut string-contains <> hash-part) paths) + #f) + (update-progress!)) + #f) + (else ; transient failure + (if len + (get-bytevector-n port len) + (read-to-eof port)) + #f)))) + + (and (string=? (cache-store-directory cache) (%store-prefix)) + (let ((uri (string->uri url))) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url requests + handle-narinfo-response))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))))) + +(define (lookup-narinfos cache paths) + "Return the narinfos for PATHS, invoking the server at CACHE when no +information is available locally." + (let-values (((cached missing) + (fold2 (lambda (path cached missing) + (let-values (((valid? value) + (cached-narinfo path))) + (if valid? + (values (cons value cached) missing) + (values cached (cons path missing))))) + '() + '() + paths))) + (if (null? missing) + cached + (let* ((cache (force cache)) + (missing (if cache + (fetch-narinfos cache missing) + '()))) + (append cached missing))))) + +(define (lookup-narinfo cache path) + "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was +found." + (match (lookup-narinfos cache (list path)) + ((answer) answer))) + +(define (remove-expired-cached-narinfos) + "Remove expired narinfo entries from the cache. The sole purpose of this +function is to make sure `%narinfo-cache-directory' doesn't grow +indefinitely." + (define now + (current-time time-monotonic)) + + (define (expired? file) + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (port) + (match (read port) + (('narinfo ('version 1) ('cache-uri _) ('date date) + ('value #f)) + (obsolete? date now %narinfo-negative-ttl)) + (('narinfo ('version 1) ('cache-uri _) ('date date) + ('value _)) + (obsolete? date now %narinfo-ttl)) + (_ #t))))) + (lambda args + ;; FILE may have been deleted. + #t))) + + (for-each (lambda (file) + (let ((file (string-append %narinfo-cache-directory + "/" file))) + (when (expired? file) + ;; Wrap in `false-if-exception' because FILE might have been + ;; deleted in the meantime (TOCTTOU). + (false-if-exception (delete-file file))))) + (scandir %narinfo-cache-directory + (lambda (file) + (= (string-length file) 32))))) + +(define (maybe-remove-expired-cached-narinfo) + "Remove expired narinfo entries from the cache if deemed necessary." + (define now + (current-time time-monotonic)) + + (define expiry-file + (string-append %narinfo-cache-directory "/last-expiry-cleanup")) + + (define last-expiry-date + (or (false-if-exception + (call-with-input-file expiry-file read)) + 0)) + + (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay) + (remove-expired-cached-narinfos) + (call-with-output-file expiry-file + (cute write (time-second now) <>)))) + +(define (progress-report-port report-progress port) + "Return a port that calls REPORT-PROGRESS every time something is read from +PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by +`progress-proc'." + (define total 0) + (define (read! bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report-progress total (const n)) + ;; XXX: We're not in control, so we always return anyway. + n)) + + ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done, + ;; don't pretend to report any progress in that case. + (if (guile-version>? "2.0.5") + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port)) + (begin + (format (current-error-port) (_ "Downloading, please wait...~%")) + (format (current-error-port) + (_ "(Please consider upgrading Guile to get proper progress report.)~%")) + port))) + +(define-syntax with-networking + (syntax-rules () + "Catch DNS lookup errors and gracefully exit." + ;; Note: no attempt is made to catch other networking errors, because DNS + ;; lookup errors are typically the first one, and because other errors are + ;; a subset of `system-error', which is harder to filter. + ((_ exp ...) + (catch 'getaddrinfo-error + (lambda () exp ...) + (lambda (key error) + (leave (_ "host name lookup error: ~a~%") + (gai-strerror error))))))) + + +;;; +;;; Help. +;;; + +(define (show-help) + (display (_ "Usage: guix substitute [OPTION]... +Internal tool to substitute a pre-built binary to a local build.\n")) + (display (_ " + --query report on the availability of substitutes for the + store file names passed on the standard input")) + (display (_ " + --substitute STORE-FILE DESTINATION + download STORE-FILE and store it as a Nar in file + DESTINATION")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + + +;;; +;;; Entry point. +;;; + +(define (check-acl-initialized) + "Warn if the ACL is uninitialized." + (define (singleton? acl) + ;; True if ACL contains just the user's public key. + (and (file-exists? %public-key-file) + (let ((key (call-with-input-file %public-key-file + (compose string->canonical-sexp + get-string-all)))) + (match acl + ((thing) + (equal? (canonical-sexp->string thing) + (canonical-sexp->string key))) + (_ + #f))))) + + (let ((acl (acl->public-keys (current-acl)))) + (when (or (null? acl) (singleton? acl)) + (warning (_ "ACL for archive imports seems to be uninitialized, \ +substitutes may be unavailable\n"))))) + +(define (daemon-options) + "Return a list of name/value pairs denoting build daemon options." + (define %not-newline + (char-set-complement (char-set #\newline))) + + (match (getenv "_NIX_OPTIONS") + (#f ;should not happen when called by the daemon + '()) + (newline-separated + ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n". + (filter-map (lambda (option=value) + (match (string-index option=value #\=) + (#f ;invalid option setting + #f) + (equal-sign + (cons (string-take option=value equal-sign) + (string-drop option=value (+ 1 equal-sign)))))) + (string-tokenize newline-separated %not-newline))))) + +(define (find-daemon-option option) + "Return the value of build daemon option OPTION, or #f if it could not be +found." + (assoc-ref (daemon-options) option)) + +(define %cache-url + (match (and=> ;; TODO: Uncomment the following lines when multiple + ;; substitute sources are supported. + ;; (find-daemon-option "untrusted-substitute-urls") ;client + ;; " " + (find-daemon-option "substitute-urls") ;admin + string-tokenize) + ((url) + url) + ((head tail ..1) + ;; Currently we don't handle multiple substitute URLs. + (warning (_ "these substitute URLs will not be used:~{ ~a~}~%") + tail) + head) + (#f + ;; This can only happen when this script is not invoked by the + ;; daemon. + "http://hydra.gnu.org"))) + +(define (guix-substitute . args) + "Implement the build daemon's substituter protocol." + (mkdir-p %narinfo-cache-directory) + (maybe-remove-expired-cached-narinfo) + (check-acl-initialized) + + ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly + ;; when we know we cannot substitute, but we must emit a newline on stdout + ;; when everything is alright. + (let ((uri (string->uri %cache-url))) + (case (uri-scheme uri) + ((http) + ;; Exit gracefully if there's no network access. + (let ((host (uri-host uri))) + (catch 'getaddrinfo-error + (lambda () + (getaddrinfo host)) + (lambda (key error) + (warning (_ "failed to look up host '~a' (~a), \ +substituter disabled~%") + host (gai-strerror error)) + (exit 0))))) + (else #t))) + + ;; Say hello (see above.) + (newline) + (force-output (current-output-port)) + + (with-networking + (with-error-handling ; for signature errors + (match args + (("--query") + (let ((cache (open-cache* %cache-url)) + (acl (current-acl))) + (define (valid? obj) + (and (narinfo? obj) (valid-narinfo? obj acl))) + + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (match (string-tokenize command) + (("have" paths ..1) + ;; Return the subset of PATHS available in CACHE. + (let ((substitutable + (if cache + (lookup-narinfos cache paths) + '()))) + (for-each (lambda (narinfo) + (format #t "~a~%" (narinfo-path narinfo))) + (filter valid? substitutable)) + (newline))) + (("info" paths ..1) + ;; Reply info about PATHS if it's in CACHE. + (let ((substitutable + (if cache + (lookup-narinfos cache paths) + '()))) + (for-each (lambda (narinfo) + (format #t "~a\n~a\n~a\n" + (narinfo-path narinfo) + (or (and=> (narinfo-deriver narinfo) + (cute string-append + (%store-prefix) "/" + <>)) + "") + (length (narinfo-references narinfo))) + (for-each (cute format #t "~a/~a~%" + (%store-prefix) <>) + (narinfo-references narinfo)) + (format #t "~a\n~a\n" + (or (narinfo-file-size narinfo) 0) + (or (narinfo-size narinfo) 0))) + (filter valid? substitutable)) + (newline))) + (wtf + (error "unknown `--query' command" wtf))) + (loop (read-line))))))) + (("--substitute" store-path destination) + ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. + (let* ((cache (open-cache* %cache-url)) + (narinfo (lookup-narinfo cache store-path)) + (uri (narinfo-uri narinfo))) + ;; Make sure it is signed and everything. + (assert-valid-narinfo narinfo) + + ;; Tell the daemon what the expected hash of the Nar itself is. + (format #t "~a~%" (narinfo-hash narinfo)) + + (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" + store-path + + ;; Use the Nar size as an estimate of the installed size. + (narinfo-size narinfo) + (and=> (narinfo-size narinfo) + (cute / <> (expt 2. 20)))) + (let*-values (((raw download-size) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. + (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) + ((input pids) + (decompressed-port (and=> (narinfo-compression narinfo) + string->symbol) + progress))) + ;; Unpack the Nar at INPUT into DESTINATION. + (restore-file input destination) + + ;; Skip a line after what 'progress-proc' printed. + (newline (current-error-port)) + + (every (compose zero? cdr waitpid) pids)))) + (("--version") + (show-version-and-exit "guix substitute")) + (("--help") + (show-help)) + (opts + (leave (_ "~a: unrecognized options~%") opts)))))) + + +;;; Local Variables: +;;; eval: (put 'with-timeout 'scheme-indent-function 1) +;;; End: + +;;; substitute.scm ends here diff --git a/guix/tests.scm b/guix/tests.scm index 0896e842da..080ee9cc74 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -126,7 +126,7 @@ Deriver: ~a~%" (define* (call-with-derivation-narinfo drv thunk #:key (sha256 (make-bytevector 32 0))) "Call THUNK in a context where fake substituter data, as read by 'guix -substitute-binary', has been installed for DRV. SHA256 is the hash of the +substitute', has been installed for DRV. SHA256 is the hash of the expected output of DRV." (let* ((output (derivation->output-path drv)) (dir (%substitute-directory)) @@ -178,7 +178,7 @@ CONTENTS." (lambda () (let ((hash (call-with-input-file (string-append dir "/example.nar") port-sha256))) - ;; Create fake substituter data, to be read by `substitute-binary'. + ;; Create fake substituter data, to be read by 'guix substitute'. (call-with-derivation-narinfo drv thunk #:sha256 (or sha256 hash)))) diff --git a/guix/ui.scm b/guix/ui.scm index ae37c8e6ca..4929f93590 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -815,7 +815,7 @@ parameter of 'args-fold'." (define (show-guix-help) (define (internal? command) - (member command '("substitute-binary" "authenticate" "offload"))) + (member command '("substitute" "authenticate" "offload"))) (format #t (_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) diff --git a/nix/scripts/substitute-binary.in b/nix/scripts/substitute-binary.in deleted file mode 100644 index 48d7bb8ff1..0000000000 --- a/nix/scripts/substitute-binary.in +++ /dev/null @@ -1,11 +0,0 @@ -#!@SHELL@ -# A shorthand for "guix substitute-binary", for use by the daemon. - -if test "x$GUIX_UNINSTALLED" = "x" -then - prefix="@prefix@" - exec_prefix="@exec_prefix@" - exec "@bindir@/guix" substitute-binary "$@" -else - exec guix substitute-binary "$@" -fi diff --git a/nix/scripts/substitute.in b/nix/scripts/substitute.in new file mode 100644 index 0000000000..5a2eeb7259 --- /dev/null +++ b/nix/scripts/substitute.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix substitute", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" substitute "$@" +else + exec guix substitute "$@" +fi diff --git a/pre-inst-env.in b/pre-inst-env.in index ef9a3ce3c3..fe56da6944 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -44,7 +44,7 @@ export PATH # Daemon helpers. NIX_ROOT_FINDER="$abs_top_builddir/nix/scripts/list-runtime-roots" -NIX_SUBSTITUTERS="$abs_top_builddir/nix/scripts/substitute-binary" +NIX_SUBSTITUTERS="$abs_top_builddir/nix/scripts/substitute" NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload" NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" # for 'guix-authenticate' diff --git a/tests/store.scm b/tests/store.scm index 9ed78be085..8e929bbc4d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -367,7 +367,7 @@ (with-store s (let* ((d (package-derivation s %bootstrap-guile (%current-system))) (o (derivation->output-path d))) - ;; Create fake substituter data, to be read by `substitute-binary'. + ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Remove entry from the local cache. (false-if-exception @@ -375,7 +375,7 @@ "/guix/substitute-binary/" (store-path-hash-part o)))) - ;; Make sure `substitute-binary' correctly communicates the above + ;; Make sure 'guix substitute' correctly communicates the above ;; data. (set-build-options s #:use-substitutes? #t) (and (has-substitutes? s o) @@ -439,7 +439,7 @@ (with-derivation-substitute d c (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C - ;; Make sure we use `substitute-binary'. + ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t #:fallback? #f) @@ -464,9 +464,9 @@ #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) - ;; Create fake substituter data, to be read by `substitute-binary'. + ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d - ;; Make sure we use `substitute-binary'. + ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t) (and (has-substitutes? s o) (guard (c ((nix-protocol-error? c) diff --git a/tests/substitute-binary.scm b/tests/substitute-binary.scm deleted file mode 100644 index 7c1204c1ab..0000000000 --- a/tests/substitute-binary.scm +++ /dev/null @@ -1,284 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (test-substitute-binary) - #:use-module (guix scripts substitute-binary) - #:use-module (guix base64) - #:use-module (guix hash) - #:use-module (guix serialization) - #:use-module (guix pk-crypto) - #:use-module (guix pki) - #:use-module (guix config) - #:use-module (guix base32) - #:use-module ((guix store) #:select (%store-prefix)) - #:use-module ((guix ui) #:select (guix-warning-port)) - #:use-module ((guix build utils) #:select (delete-file-recursively)) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (web uri) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) - #:use-module ((srfi srfi-64) #:hide (test-error))) - -(define-syntax-rule (test-quit name error-rx exp) - "Emit a test that passes when EXP throws to 'quit' with value 1, and when -it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." - (test-equal name - '(1 #t) - (let ((error-output (open-output-string))) - (parameterize ((guix-warning-port error-output)) - (catch 'quit - (lambda () - exp - #f) - (lambda (key value) - (list value - (let ((message (get-output-string error-output))) - (->bool (string-match error-rx message)))))))))) - -(define %public-key - ;; This key is known to be in the ACL by default. - (call-with-input-file (string-append %config-directory "/signing-key.pub") - (compose string->canonical-sexp get-string-all))) - -(define %private-key - (call-with-input-file (string-append %config-directory "/signing-key.sec") - (compose string->canonical-sexp get-string-all))) - -(define* (signature-body bv #:key (public-key %public-key)) - "Return the signature of BV as the base64-encoded body of a narinfo's -'Signature' field." - (base64-encode - (string->utf8 - (canonical-sexp->string - (signature-sexp (bytevector->hash-data (sha256 bv) - #:key-type 'rsa) - %private-key - public-key))))) - -(define %wrong-public-key - (string->canonical-sexp "(public-key - (rsa - (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) - (e #010001#) - ) - )")) - -(define* (signature-field bv-or-str - #:key (version "1") (public-key %public-key)) - "Return the 'Signature' field value of bytevector/string BV-OR-STR, using -PUBLIC-KEY as the signature's principal, and using VERSION as the signature -version identifier.." - (string-append version ";example.gnu.org;" - (signature-body (if (string? bv-or-str) - (string->utf8 bv-or-str) - bv-or-str) - #:public-key public-key))) - - - -(test-begin "substitute-binary") - -(test-quit "not a number" - "signature version" - (narinfo-signature->canonical-sexp - (signature-field "foo" #:version "not a number"))) - -(test-quit "wrong version number" - "unsupported.*version" - (narinfo-signature->canonical-sexp - (signature-field "foo" #:version "2"))) - -(test-assert "valid narinfo-signature->canonical-sexp" - (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo")))) - - - -(define %narinfo - ;; Skeleton of the narinfo used below. - (string-append "StorePath: " (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo -URL: example.nar -Compression: none -NarHash: sha256:" (bytevector->nix-base32-string - (sha256 (string->utf8 "Substitutable data."))) " -NarSize: 42 -References: bar baz -Deriver: " (%store-prefix) "/foo.drv -System: mips64el-linux\n")) - -(define (call-with-narinfo narinfo thunk) - "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with -a file for NARINFO." - (let ((narinfo-directory (and=> (string->uri (getenv - "GUIX_BINARY_SUBSTITUTE_URL")) - uri-path)) - (cache-directory (string-append (getenv "XDG_CACHE_HOME") - "/guix/substitute-binary/"))) - (dynamic-wind - (lambda () - (when (file-exists? cache-directory) - (delete-file-recursively cache-directory)) - (call-with-output-file (string-append narinfo-directory - "/nix-cache-info") - (lambda (port) - (format port "StoreDir: ~a\nWantMassQuery: 0\n" - (%store-prefix)))) - (call-with-output-file (string-append narinfo-directory "/" - "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" - ".narinfo") - (cut display narinfo <>)) - - ;; Prepare the nar. - (call-with-output-file - (string-append narinfo-directory "/example.out") - (cut display "Substitutable data." <>)) - (call-with-output-file - (string-append narinfo-directory "/example.nar") - (cute write-file - (string-append narinfo-directory "/example.out") <>)) - - (set! (@@ (guix scripts substitute-binary) - %allow-unauthenticated-substitutes?) - #f)) - thunk - (lambda () - (delete-file-recursively cache-directory))))) - -(define-syntax-rule (with-narinfo narinfo body ...) - (call-with-narinfo narinfo (lambda () body ...))) - -;; Transmit these options to 'guix substitute-binary'. -(set! (@@ (guix scripts substitute-binary) %cache-url) - (getenv "GUIX_BINARY_SUBSTITUTE_URL")) - -(test-equal "query narinfo without signature" - "" ; not substitutable - - (with-narinfo %narinfo - (string-trim-both - (with-output-to-string - (lambda () - (with-input-from-string (string-append "have " (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - (lambda () - (guix-substitute-binary "--query")))))))) - -(test-equal "query narinfo with invalid hash" - ;; The hash in the signature differs from the hash of %NARINFO. - "" - - (with-narinfo (string-append %narinfo "Signature: " - (signature-field "different body") - "\n") - (string-trim-both - (with-output-to-string - (lambda () - (with-input-from-string (string-append "have " (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - (lambda () - (guix-substitute-binary "--query")))))))) - -(test-equal "query narinfo signed with authorized key" - (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - - (with-narinfo (string-append %narinfo "Signature: " - (signature-field %narinfo) - "\n") - (string-trim-both - (with-output-to-string - (lambda () - (with-input-from-string (string-append "have " (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - (lambda () - (guix-substitute-binary "--query")))))))) - -(test-equal "query narinfo signed with unauthorized key" - "" ; not substitutable - - (with-narinfo (string-append %narinfo "Signature: " - (signature-field - %narinfo - #:public-key %wrong-public-key) - "\n") - (string-trim-both - (with-output-to-string - (lambda () - (with-input-from-string (string-append "have " (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - (lambda () - (guix-substitute-binary "--query")))))))) - -(test-quit "substitute, no signature" - "lacks a signature" - (with-narinfo %narinfo - (guix-substitute-binary "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) - -(test-quit "substitute, invalid hash" - "hash" - ;; The hash in the signature differs from the hash of %NARINFO. - (with-narinfo (string-append %narinfo "Signature: " - (signature-field "different body") - "\n") - (guix-substitute-binary "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) - -(test-quit "substitute, unauthorized key" - "unauthorized" - (with-narinfo (string-append %narinfo "Signature: " - (signature-field - %narinfo - #:public-key %wrong-public-key) - "\n") - (guix-substitute-binary "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) - -(test-equal "substitute, authorized key" - "Substitutable data." - (with-narinfo (string-append %narinfo "Signature: " - (signature-field %narinfo)) - (dynamic-wind - (const #t) - (lambda () - (guix-substitute-binary "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved") - (call-with-input-file "substitute-retrieved" get-string-all)) - (lambda () - (false-if-exception (delete-file "substitute-retrieved")))))) - -(test-end "substitute-binary") - - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) - -;;; Local Variables: -;;; eval: (put 'with-narinfo 'scheme-indent-function 1) -;;; eval: (put 'test-quit 'scheme-indent-function 2) -;;; End: diff --git a/tests/substitute.scm b/tests/substitute.scm new file mode 100644 index 0000000000..5697592423 --- /dev/null +++ b/tests/substitute.scm @@ -0,0 +1,284 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Nikita Karetnikov +;;; Copyright © 2014, 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-substitute) + #:use-module (guix scripts substitute) + #:use-module (guix base64) + #:use-module (guix hash) + #:use-module (guix serialization) + #:use-module (guix pk-crypto) + #:use-module (guix pki) + #:use-module (guix config) + #:use-module (guix base32) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module ((guix ui) #:select (guix-warning-port)) + #:use-module ((guix build utils) #:select (delete-file-recursively)) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (web uri) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module ((srfi srfi-64) #:hide (test-error))) + +(define-syntax-rule (test-quit name error-rx exp) + "Emit a test that passes when EXP throws to 'quit' with value 1, and when +it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." + (test-equal name + '(1 #t) + (let ((error-output (open-output-string))) + (parameterize ((guix-warning-port error-output)) + (catch 'quit + (lambda () + exp + #f) + (lambda (key value) + (list value + (let ((message (get-output-string error-output))) + (->bool (string-match error-rx message)))))))))) + +(define %public-key + ;; This key is known to be in the ACL by default. + (call-with-input-file (string-append %config-directory "/signing-key.pub") + (compose string->canonical-sexp get-string-all))) + +(define %private-key + (call-with-input-file (string-append %config-directory "/signing-key.sec") + (compose string->canonical-sexp get-string-all))) + +(define* (signature-body bv #:key (public-key %public-key)) + "Return the signature of BV as the base64-encoded body of a narinfo's +'Signature' field." + (base64-encode + (string->utf8 + (canonical-sexp->string + (signature-sexp (bytevector->hash-data (sha256 bv) + #:key-type 'rsa) + %private-key + public-key))))) + +(define %wrong-public-key + (string->canonical-sexp "(public-key + (rsa + (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) + (e #010001#) + ) + )")) + +(define* (signature-field bv-or-str + #:key (version "1") (public-key %public-key)) + "Return the 'Signature' field value of bytevector/string BV-OR-STR, using +PUBLIC-KEY as the signature's principal, and using VERSION as the signature +version identifier.." + (string-append version ";example.gnu.org;" + (signature-body (if (string? bv-or-str) + (string->utf8 bv-or-str) + bv-or-str) + #:public-key public-key))) + + + +(test-begin "substitute") + +(test-quit "not a number" + "signature version" + (narinfo-signature->canonical-sexp + (signature-field "foo" #:version "not a number"))) + +(test-quit "wrong version number" + "unsupported.*version" + (narinfo-signature->canonical-sexp + (signature-field "foo" #:version "2"))) + +(test-assert "valid narinfo-signature->canonical-sexp" + (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo")))) + + + +(define %narinfo + ;; Skeleton of the narinfo used below. + (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string + (sha256 (string->utf8 "Substitutable data."))) " +NarSize: 42 +References: bar baz +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n")) + +(define (call-with-narinfo narinfo thunk) + "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with +a file for NARINFO." + (let ((narinfo-directory (and=> (string->uri (getenv + "GUIX_BINARY_SUBSTITUTE_URL")) + uri-path)) + (cache-directory (string-append (getenv "XDG_CACHE_HOME") + "/guix/substitute-binary/"))) + (dynamic-wind + (lambda () + (when (file-exists? cache-directory) + (delete-file-recursively cache-directory)) + (call-with-output-file (string-append narinfo-directory + "/nix-cache-info") + (lambda (port) + (format port "StoreDir: ~a\nWantMassQuery: 0\n" + (%store-prefix)))) + (call-with-output-file (string-append narinfo-directory "/" + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + ".narinfo") + (cut display narinfo <>)) + + ;; Prepare the nar. + (call-with-output-file + (string-append narinfo-directory "/example.out") + (cut display "Substitutable data." <>)) + (call-with-output-file + (string-append narinfo-directory "/example.nar") + (cute write-file + (string-append narinfo-directory "/example.out") <>)) + + (set! (@@ (guix scripts substitute) + %allow-unauthenticated-substitutes?) + #f)) + thunk + (lambda () + (delete-file-recursively cache-directory))))) + +(define-syntax-rule (with-narinfo narinfo body ...) + (call-with-narinfo narinfo (lambda () body ...))) + +;; Transmit these options to 'guix substitute'. +(set! (@@ (guix scripts substitute) %cache-url) + (getenv "GUIX_BINARY_SUBSTITUTE_URL")) + +(test-equal "query narinfo without signature" + "" ; not substitutable + + (with-narinfo %narinfo + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query")))))))) + +(test-equal "query narinfo with invalid hash" + ;; The hash in the signature differs from the hash of %NARINFO. + "" + + (with-narinfo (string-append %narinfo "Signature: " + (signature-field "different body") + "\n") + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query")))))))) + +(test-equal "query narinfo signed with authorized key" + (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + + (with-narinfo (string-append %narinfo "Signature: " + (signature-field %narinfo) + "\n") + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query")))))))) + +(test-equal "query narinfo signed with unauthorized key" + "" ; not substitutable + + (with-narinfo (string-append %narinfo "Signature: " + (signature-field + %narinfo + #:public-key %wrong-public-key) + "\n") + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query")))))))) + +(test-quit "substitute, no signature" + "lacks a signature" + (with-narinfo %narinfo + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "foo"))) + +(test-quit "substitute, invalid hash" + "hash" + ;; The hash in the signature differs from the hash of %NARINFO. + (with-narinfo (string-append %narinfo "Signature: " + (signature-field "different body") + "\n") + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "foo"))) + +(test-quit "substitute, unauthorized key" + "unauthorized" + (with-narinfo (string-append %narinfo "Signature: " + (signature-field + %narinfo + #:public-key %wrong-public-key) + "\n") + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "foo"))) + +(test-equal "substitute, authorized key" + "Substitutable data." + (with-narinfo (string-append %narinfo "Signature: " + (signature-field %narinfo)) + (dynamic-wind + (const #t) + (lambda () + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "substitute-retrieved") + (call-with-input-file "substitute-retrieved" get-string-all)) + (lambda () + (false-if-exception (delete-file "substitute-retrieved")))))) + +(test-end "substitute") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'with-narinfo 'scheme-indent-function 1) +;;; eval: (put 'test-quit 'scheme-indent-function 2) +;;; End: -- cgit v1.2.3