Add 'guix challenge'.
* guix/scripts/challenge.scm, tests/challenge.scm: New files. * Makefile.am (MODULES): Add the former. (SCM_TESTS): Add the latter. * doc.am (SUBCOMMANDS): Add 'challenge'. * doc/guix.texi (Substitutes): Add xref to 'guix challenge'. (Invoking guix challenge): New node. * doc/contributing.texi (Submitting Patches): Add note about using 'guix challenge'. * po/guix/POTFILES.in: Add guix/scripts/challenge.scm.master
parent
ea0c6e0507
commit
d23c20f1d0
|
@ -116,6 +116,7 @@ MODULES = \
|
|||
guix/scripts/refresh.scm \
|
||||
guix/scripts/system.scm \
|
||||
guix/scripts/lint.scm \
|
||||
guix/scripts/challenge.scm \
|
||||
guix/scripts/import/cran.scm \
|
||||
guix/scripts/import/gnu.scm \
|
||||
guix/scripts/import/nix.scm \
|
||||
|
@ -218,6 +219,7 @@ SCM_TESTS = \
|
|||
tests/scripts.scm \
|
||||
tests/size.scm \
|
||||
tests/graph.scm \
|
||||
tests/challenge.scm \
|
||||
tests/file-systems.scm \
|
||||
tests/services.scm \
|
||||
tests/containers.scm
|
||||
|
|
1
doc.am
1
doc.am
|
@ -113,6 +113,7 @@ endef
|
|||
SUBCOMMANDS := \
|
||||
archive \
|
||||
build \
|
||||
challenge \
|
||||
download \
|
||||
edit \
|
||||
environment \
|
||||
|
|
|
@ -234,6 +234,17 @@ For important changes, check that dependent package (if applicable) are
|
|||
not affected by the change; @code{guix refresh --list-dependent
|
||||
@var{package}} will help you do that (@pxref{Invoking guix refresh}).
|
||||
|
||||
@item
|
||||
Check whether the package's build process is deterministic. This
|
||||
typically means checking whether an independent build of the package
|
||||
yields the exact same result that you obtained, bit for bit.
|
||||
|
||||
A simple way to do that is with @command{guix challenge}
|
||||
(@pxref{Invoking guix challenge}). You may run it once the package has
|
||||
been committed and built by @code{hydra.gnu.org} to check whether it
|
||||
obtains the same result as you did. Better yet: Find another machine
|
||||
that can build it and run @command{guix publish}.
|
||||
|
||||
@end enumerate
|
||||
|
||||
When posting a patch to the mailing list, use @samp{[PATCH] @dots{}} as a
|
||||
|
|
129
doc/guix.texi
129
doc/guix.texi
|
@ -143,6 +143,7 @@ Utilities
|
|||
* Invoking guix graph:: Visualizing the graph of packages.
|
||||
* Invoking guix environment:: Setting up development environments.
|
||||
* Invoking guix publish:: Sharing substitutes.
|
||||
* Invoking guix challenge:: Challenging substitute servers.
|
||||
|
||||
GNU Distribution
|
||||
|
||||
|
@ -1600,7 +1601,10 @@ Guix has the foundations to maximize build reproducibility
|
|||
(@pxref{Features}). In most cases, independent builds of a given
|
||||
package or derivation should yield bit-identical results. Thus, through
|
||||
a diverse set of independent package builds, we can strengthen the
|
||||
integrity of our systems.
|
||||
integrity of our systems. The @command{guix challenge} command aims to
|
||||
help users assess substitute servers, and to assist developers in
|
||||
finding out about non-deterministic package builds (@pxref{Invoking guix
|
||||
challenge}).
|
||||
|
||||
In the future, we want Guix to have support to publish and retrieve
|
||||
binaries to/from other users, in a peer-to-peer fashion. If you would
|
||||
|
@ -3577,6 +3581,7 @@ programming interface of Guix in a convenient way.
|
|||
* Invoking guix graph:: Visualizing the graph of packages.
|
||||
* Invoking guix environment:: Setting up development environments.
|
||||
* Invoking guix publish:: Sharing substitutes.
|
||||
* Invoking guix challenge:: Challenging substitute servers.
|
||||
@end menu
|
||||
|
||||
@node Invoking guix build
|
||||
|
@ -4776,6 +4781,128 @@ Reference Manual}) on @var{port} (37146 by default). This is used
|
|||
primarily for debugging a running @command{guix publish} server.
|
||||
@end table
|
||||
|
||||
|
||||
@node Invoking guix challenge
|
||||
@section Invoking @command{guix challenge}
|
||||
|
||||
@cindex reproducible builds
|
||||
@cindex verifiable builds
|
||||
|
||||
Do the binaries provided by this server really correspond to the source
|
||||
code it claims to build? Is this package's build process deterministic?
|
||||
These are the questions the @command{guix challenge} command attempts to
|
||||
answer.
|
||||
|
||||
The former is obviously an important question: Before using a substitute
|
||||
server (@pxref{Substitutes}), you'd rather @emph{verify} that it
|
||||
provides the right binaries, and thus @emph{challenge} it. The latter
|
||||
is what enables the former: If package builds are deterministic, then
|
||||
independent builds of the package should yield the exact same result,
|
||||
bit for bit; if a server provides a binary different from the one
|
||||
obtained locally, it may be either corrupt or malicious.
|
||||
|
||||
We know that the hash that shows up in @file{/gnu/store} file names is
|
||||
the hash of all the inputs of the process that built the file or
|
||||
directory---compilers, libraries, build scripts,
|
||||
etc. (@pxref{Introduction}). Assuming deterministic build processes,
|
||||
one store file name should map to exactly one build output.
|
||||
@command{guix challenge} checks whether there is, indeed, a single
|
||||
mapping by comparing the build outputs of several independent builds of
|
||||
any given store item.
|
||||
|
||||
The command's output looks like this:
|
||||
|
||||
@smallexample
|
||||
$ guix challenge --substitute-urls="http://hydra.gnu.org http://guix.example.org"
|
||||
updating list of substitutes from 'http://hydra.gnu.org'... 100.0%
|
||||
updating list of substitutes from 'http://guix.example.org'... 100.0%
|
||||
/gnu/store/@dots{}-openssl-1.0.2d contents differ:
|
||||
local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
|
||||
http://hydra.gnu.org/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
|
||||
http://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim
|
||||
/gnu/store/@dots{}-git-2.5.0 contents differ:
|
||||
local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha
|
||||
http://hydra.gnu.org/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f
|
||||
http://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
|
||||
/gnu/store/@dots{}-pius-2.1.1 contents differ:
|
||||
local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
|
||||
http://hydra.gnu.org/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
|
||||
http://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs
|
||||
@end smallexample
|
||||
|
||||
@noindent
|
||||
In this example, @command{guix challenge} first scans the store to
|
||||
determine the set of locally-built derivations---as opposed to store
|
||||
items that were downloaded from a substitute server---and then queries
|
||||
all the substitute servers. It then reports those store items for which
|
||||
the servers obtained a result different from the local build.
|
||||
|
||||
@cindex non-determinism, in package builds
|
||||
As an example, @code{guix.example.org} always gets a different answer.
|
||||
Conversely, @code{hydra.gnu.org} agrees with local builds, except in the
|
||||
case of Git. This might indicate that the build process of Git is
|
||||
non-deterministic, meaning that its output varies as a function of
|
||||
various things that Guix does not fully control, in spite of building
|
||||
packages in isolated environments (@pxref{Features}). Most common
|
||||
sources of non-determinism include the addition of timestamps in build
|
||||
results, the inclusion of random numbers, and directory listings sorted
|
||||
by inode number. See @uref{http://reproducible.debian.net/howto/}, for
|
||||
more information.
|
||||
|
||||
To find out what's wrong with this Git binary, we can do something along
|
||||
these lines (@pxref{Invoking guix archive}):
|
||||
|
||||
@example
|
||||
$ wget -q -O - http://hydra.gnu.org/nar/@dots{}-git-2.5.0 \
|
||||
| guix archive -x /tmp/git
|
||||
$ diff -ur /gnu/store/@dots{}-git.2.5.0 /tmp/git
|
||||
@end example
|
||||
|
||||
This command shows the difference between the files resulting from the
|
||||
local build, and the files resulting from the build on
|
||||
@code{hydra.gnu.org} (@pxref{Overview, Comparing and Merging Files,,
|
||||
diffutils, Comparing and Merging Files}). The @command{diff} command
|
||||
works great for text files. When binary files differ, a better option
|
||||
is @uref{http://diffoscope.org/, Diffoscope}, a tool that helps
|
||||
visualize differences for all kinds of files.
|
||||
|
||||
Once you've done that work, you can tell whether the differences are due
|
||||
to a non-deterministic build process or to a malicious server. We try
|
||||
hard to remove sources of non-determinism in packages to make it easier
|
||||
to verify substitutes, but of course, this is a process, one that
|
||||
involves not just Guix but a large part of the free software community.
|
||||
In the meantime, @command{guix challenge} is one tool to help address
|
||||
the problem.
|
||||
|
||||
If you are writing packages for Guix, you are encouraged to check
|
||||
whether @code{hydra.gnu.org} and other substitute servers obtain the
|
||||
same build result as you did with:
|
||||
|
||||
@example
|
||||
$ guix challenge @var{package}
|
||||
@end example
|
||||
|
||||
@noindent
|
||||
... where @var{package} is a package specification such as
|
||||
@code{guile-2.0} or @code{glibc:debug}.
|
||||
|
||||
The general syntax is:
|
||||
|
||||
@example
|
||||
guix challenge @var{options} [@var{packages}@dots{}]
|
||||
@end example
|
||||
|
||||
The one option that matters is:
|
||||
|
||||
@table @code
|
||||
|
||||
@item --substitute-urls=@var{urls}
|
||||
Consider @var{urls} the whitespace-separated list of substitute source
|
||||
URLs to compare to.
|
||||
|
||||
@end table
|
||||
|
||||
|
||||
@c *********************************************************************
|
||||
@node GNU Distribution
|
||||
@chapter GNU Distribution
|
||||
|
|
|
@ -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
|
|
@ -22,6 +22,7 @@ guix/scripts/publish.scm
|
|||
guix/scripts/edit.scm
|
||||
guix/scripts/size.scm
|
||||
guix/scripts/graph.scm
|
||||
guix/scripts/challenge.scm
|
||||
guix/gnu-maintenance.scm
|
||||
guix/ui.scm
|
||||
guix/http-client.scm
|
||||
|
|
|
@ -0,0 +1,114 @@
|
|||
;;; 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 (test-challenge)
|
||||
#:use-module (guix tests)
|
||||
#:use-module (guix hash)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix scripts challenge)
|
||||
#:use-module (guix scripts substitute)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
(define %store
|
||||
(open-connection-for-tests))
|
||||
|
||||
(define query-path-hash*
|
||||
(store-lift query-path-hash))
|
||||
|
||||
(define-syntax-rule (test-assertm name exp)
|
||||
(test-assert name
|
||||
(run-with-store %store exp
|
||||
#:guile-for-build (%guile-for-build))))
|
||||
|
||||
(define* (call-with-derivation-narinfo* drv thunk hash)
|
||||
(lambda (store)
|
||||
(with-derivation-narinfo drv (sha256 => hash)
|
||||
(values (run-with-store store (thunk)) store))))
|
||||
|
||||
(define-syntax with-derivation-narinfo*
|
||||
(syntax-rules (sha256 =>)
|
||||
((_ drv (sha256 => hash) body ...)
|
||||
(call-with-derivation-narinfo* drv
|
||||
(lambda () body ...)
|
||||
hash))))
|
||||
|
||||
|
||||
(test-begin "challenge")
|
||||
|
||||
(test-assertm "no discrepancies"
|
||||
(let ((text (random-text)))
|
||||
(mlet* %store-monad ((drv (gexp->derivation "something"
|
||||
#~(call-with-output-file
|
||||
#$output
|
||||
(lambda (port)
|
||||
(display #$text port)))))
|
||||
(out -> (derivation->output-path drv)))
|
||||
(mbegin %store-monad
|
||||
(built-derivations (list drv))
|
||||
(mlet %store-monad ((hash (query-path-hash* out)))
|
||||
(with-derivation-narinfo* drv (sha256 => hash)
|
||||
(>>= (discrepancies (list out) (%test-substitute-urls))
|
||||
(lift1 null? %store-monad))))))))
|
||||
|
||||
(test-assertm "one discrepancy"
|
||||
(let ((text (random-text)))
|
||||
(mlet* %store-monad ((drv (gexp->derivation "something"
|
||||
#~(call-with-output-file
|
||||
#$output
|
||||
(lambda (port)
|
||||
(display #$text port)))))
|
||||
(out -> (derivation->output-path drv)))
|
||||
(mbegin %store-monad
|
||||
(built-derivations (list drv))
|
||||
(mlet* %store-monad ((hash (query-path-hash* out))
|
||||
(wrong-hash
|
||||
-> (let* ((w (bytevector-copy hash))
|
||||
(b (bytevector-u8-ref w 0)))
|
||||
(bytevector-u8-set! w 0
|
||||
(modulo (+ b 1) 128))
|
||||
w)))
|
||||
(with-derivation-narinfo* drv (sha256 => wrong-hash)
|
||||
(>>= (discrepancies (list out) (%test-substitute-urls))
|
||||
(match-lambda
|
||||
((discrepancy)
|
||||
(return
|
||||
(and (string=? out (discrepancy-item discrepancy))
|
||||
(bytevector=? hash
|
||||
(discrepancy-local-sha256
|
||||
discrepancy))
|
||||
(match (discrepancy-narinfos discrepancy)
|
||||
((bad)
|
||||
(bytevector=? wrong-hash
|
||||
(narinfo-hash->sha256
|
||||
(narinfo-hash bad))))))))))))))))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
|
||||
;;; End:
|
Reference in New Issue