diff options
author | Mark H Weaver <mhw@netris.org> | 2015-10-20 14:11:43 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2015-10-20 14:11:43 -0400 |
commit | 7c6fb733e91675d1a0b80e863a422a55d1f3aa5d (patch) | |
tree | a81716c171ac75e47eed09c76e2c7de45d5de28f /guix/scripts | |
parent | e38a71eea9abaa4e03ef1d7081104f93d26e31b3 (diff) | |
parent | b1599b5299c82230722ec91dbeabcf19e3399c15 (diff) |
Merge branch 'master' into dbus-update
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/archive.scm | 10 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 244 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 40 |
3 files changed, 290 insertions, 4 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index b120c555e3..1a941d1a73 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -20,6 +20,7 @@ #:use-module (guix config) #:use-module (guix utils) #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) #:use-module (guix packages) #:use-module (guix derivations) @@ -63,6 +64,8 @@ Export/import one or more packages from/to the store.\n")) --import import from the archive passed on stdin")) (display (_ " --missing print the files from stdin that are missing")) + (display (_ " + -x, --extract=DIR extract the archive on stdin to DIR")) (newline) (display (_ " --generate-key[=PARAMETERS] @@ -119,6 +122,9 @@ Export/import one or more packages from/to the store.\n")) (option '("missing") #f #f (lambda (opt name arg result) (alist-cons 'missing #t result))) + (option '("extract" #\x) #t #f + (lambda (opt name arg result) + (alist-cons 'extract arg result))) (option '("generate-key") #f #t (lambda (opt name arg result) (catch 'gcry-error @@ -328,6 +334,10 @@ the input port." (missing (remove (cut valid-path? store <>) files))) (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) (else (leave (_ "either '--export' or '--import' \ diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm new file mode 100644 index 0000000000..19a9b061b8 --- /dev/null +++ b/guix/scripts/challenge.scm @@ -0,0 +1,244 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts challenge) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix monads) + #:use-module (guix base32) + #:use-module (guix packages) + #:use-module (guix serialization) + #:use-module (guix scripts substitute) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (ice-9 format) + #:use-module (web uri) + #:export (discrepancies + + discrepancy? + discrepancy-item + discrepancy-local-sha256 + discrepancy-narinfos + + guix-challenge)) + +;;; Commentary: +;;; +;;; Challenge substitute servers, checking whether they provide the same +;;; binaries as those built locally. +;;; +;;; Here we completely bypass the daemon to access substitutes. This is +;;; because we want to be able to report fine-grain information about +;;; discrepancies: We need to show the URL of the offending nar, its hash, and +;;; so on. +;;; +;;; Code: + +(define ensure-store-item ;XXX: move to (guix ui)? + (@@ (guix scripts size) ensure-store-item)) + +;; Representation of a hash mismatch for ITEM. +(define-record-type <discrepancy> + (discrepancy item local-sha256 narinfos) + discrepancy? + (item discrepancy-item) ;string, /gnu/store/… item + (local-sha256 discrepancy-local-sha256) ;bytevector | #f + (narinfos discrepancy-narinfos)) ;list of <narinfo> + +(define (locally-built? store item) + "Return true if ITEM was built locally." + ;; XXX: For now approximate it by checking whether there's a build log for + ;; ITEM. There could be false negatives, if logs have been removed. + (->bool (log-file store item))) + +(define (query-locally-built-hash item) + "Return the hash of ITEM, a store item, if ITEM was built locally. +Otherwise return #f." + (lambda (store) + (guard (c ((nix-protocol-error? c) + (values #f store))) + (if (locally-built? store item) + (values (query-path-hash store item) store) + (values #f store))))) + +(define-syntax-rule (report args ...) + (format (current-error-port) args ...)) + +(define (discrepancies items servers) + "Challenge the substitute servers whose URLs are listed in SERVERS by +comparing the hash of the substitutes of ITEMS that they serve. Return the +list of discrepancies. + +This procedure does not authenticate narinfos from SERVERS, nor does it verify +that they are signed by an authorized public keys. The reason is that, by +definition, we may want to target unknown servers. Furthermore, no risk is +taken since we do not import the archives." + (define (compare item reference) + ;; Return a procedure to compare the hash of ITEM with REFERENCE. + (lambda (narinfo url) + (if (not narinfo) + (begin + (warning (_ "~a: no substitute at '~a'~%") + item url) + #t) + (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) + (bytevector=? reference value))))) + + (define (select-reference item narinfos urls) + ;; Return a "reference" narinfo among NARINFOS. + (match narinfos + ((first narinfos ...) + (match servers + ((url urls ...) + (if (not first) + (select-reference item narinfos urls) + (narinfo-hash->sha256 (narinfo-hash first)))))) + (() + (leave (_ "no substitutes for '~a'~%") item)))) + + (mlet* %store-monad ((local (mapm %store-monad + query-locally-built-hash items)) + (remote -> (append-map (cut lookup-narinfos <> items) + servers)) + ;; No 'assert-valid-narinfo' on purpose. + (narinfos -> (fold (lambda (narinfo vhash) + (if narinfo + (vhash-cons (narinfo-path narinfo) narinfo + vhash) + vhash)) + vlist-null + remote))) + (return (filter-map (lambda (item local) + (let ((narinfos (vhash-fold* cons '() item narinfos))) + (define reference + (or local + (begin + (warning (_ "no local build for '~a'~%") item) + (select-reference item narinfos servers)))) + + (if (every (compare item reference) + narinfos servers) + #f + (discrepancy item local narinfos)))) + items + local)))) + +(define* (summarize-discrepancy discrepancy + #:key (hash->string + bytevector->nix-base32-string)) + "Write to the current error port a summary of DISCREPANCY, a <discrepancy> +object that denotes a hash mismatch." + (match discrepancy + (($ <discrepancy> item local (narinfos ...)) + (report (_ "~a contents differ:~%") item) + (if local + (report (_ " local hash: ~a~%") (hash->string local)) + (warning (_ "no local build for '~a'~%") item)) + + (for-each (lambda (narinfo) + (if narinfo + (report (_ " ~50a: ~a~%") + (uri->string (narinfo-uri narinfo)) + (hash->string + (narinfo-hash->sha256 (narinfo-hash narinfo)))) + (report (_ " ~50a: unavailable~%") + (uri->string (narinfo-uri narinfo))))) + narinfos)))) + + +;;; +;;; Command-line options. +;;; + +(define (show-help) + (display (_ "Usage: guix challenge [PACKAGE...] +Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) + (display (_ " + --substitute-urls=URLS + compare build results with those at URLS")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix challenge"))) + + (option '("substitute-urls") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'substitute-urls + (string-tokenize arg) + (alist-delete 'substitute-urls result)) + rest))))) + +(define %default-options + `((system . ,(%current-system)) + (substitute-urls . ,%default-substitute-urls))) + + +;;; +;;; Entry point. +;;; + +(define (guix-challenge . args) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options))) + (files (filter-map (match-lambda + (('argument . file) file) + (_ #f)) + opts)) + (system (assoc-ref opts 'system)) + (urls (assoc-ref opts 'substitute-urls))) + (leave-on-EPIPE + (with-store store + (let ((files (match files + (() + (filter (cut locally-built? store <>) + (live-paths store))) + (x + files)))) + (set-build-options store + #:use-substitutes? #f) + + (run-with-store store + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (issues (discrepancies items urls))) + (for-each summarize-discrepancy issues) + (return (null? issues))) + #:system system))))))) + +;;; challenge.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ec8e6244af..8967fa062e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -53,6 +53,25 @@ #:use-module (web response) #:use-module (guix http-client) #:export (narinfo-signature->canonical-sexp + + narinfo? + narinfo-path + narinfo-uri + narinfo-uri-base + narinfo-compression + narinfo-file-hash + narinfo-file-size + narinfo-hash + narinfo-size + narinfo-references + narinfo-deriver + narinfo-system + narinfo-signature + + narinfo-hash->sha256 + assert-valid-narinfo + + lookup-narinfos read-narinfo write-narinfo guix-substitute)) @@ -231,6 +250,12 @@ object on success, or #f on failure." ;; for more information. (contents narinfo-contents)) +(define (narinfo-hash->sha256 hash) + "If the string HASH denotes a sha256 hash, return it as a bytevector. +Otherwise return #f." + (and (string-prefix? "sha256:" hash) + (nix-base32-string->bytevector (string-drop hash 7)))) + (define (narinfo-signature->canonical-sexp str) "Return the value of a narinfo's 'Signature' field as a canonical sexp." (match (string-split str #\;) @@ -429,10 +454,17 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) - (mkdir-p (dirname file)) - (with-atomic-file-output file - (lambda (out) - (write (cache-entry cache-url narinfo) out)))) + (catch 'system-error + (lambda () + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (out) + (write (cache-entry cache-url narinfo) out)))) + (lambda args + ;; We may not have write access to the local cache when called from an + ;; unprivileged process such as 'guix challenge'. + (unless (= EACCES (system-error-errno args)) + (apply throw args))))) narinfo) |