* [bug#38518] [PATCH 2/7] guix archive: Add '--list'.
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 3/7] challenge: Report the best narinfo URI Ludovic Courtès
` (4 subsequent siblings)
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/scripts/archive.scm (show-help, %options): Add '--list'.
(list-contents): New procedure.
(guix-archive): Honor the '--list' option.
* tests/guix-archive.sh: Test it.
* doc/guix.texi (Invoking guix archive): Document it.
---
doc/guix.texi | 12 +++++++++++
guix/scripts/archive.scm | 45 +++++++++++++++++++++++++++++++++++++++-
tests/guix-archive.sh | 7 ++++++-
3 files changed, 62 insertions(+), 2 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 446534c576..7b9aa7f7c3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4598,6 +4598,18 @@ unsafe.
The primary purpose of this operation is to facilitate inspection of
archive contents coming from possibly untrusted substitute servers.
+@item --list
+@itemx -t
+Read a single-item archive as served by substitute servers
+(@pxref{Substitutes}) and print the list of files it contains, as in
+this example:
+
+@example
+$ wget -O - \
+ https://@value{SUBSTITUTE-SERVER}/nar/lzip/@dots{}-emacs-26.3 \
+ | lzip -d | guix archive -t
+@end example
+
@end table
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 3318ef0889..2b4d39c7b8 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -21,7 +21,8 @@
#:use-module (guix utils)
#:use-module (guix combinators)
#:use-module ((guix build utils) #:select (mkdir-p))
- #:use-module ((guix serialization) #:select (restore-file))
+ #:use-module ((guix serialization)
+ #:select (fold-archive restore-file))
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
@@ -43,6 +44,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:export (guix-archive
options->derivations+files))
@@ -76,6 +78,8 @@ Export/import one or more packages from/to the store.\n"))
--missing print the files from stdin that are missing"))
(display (G_ "
-x, --extract=DIR extract the archive on stdin to DIR"))
+ (display (G_ "
+ -t, --list list the files in the archive on stdin"))
(newline)
(display (G_ "
--generate-key[=PARAMETERS]
@@ -137,6 +141,9 @@ Export/import one or more packages from/to the store.\n"))
(option '("extract" #\x) #t #f
(lambda (opt name arg result)
(alist-cons 'extract arg result)))
+ (option '("list" #\t) #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'list #t result)))
(option '("generate-key") #f #t
(lambda (opt name arg result)
(catch 'gcry-error
@@ -319,6 +326,40 @@ the input port."
(with-atomic-file-output %acl-file
(cut write-acl acl <>)))))
+(define (list-contents port)
+ "Read a nar from PORT and print the list of files it contains to the current
+output port."
+ (define (consume-input port size)
+ (let ((bv (make-bytevector 32768)))
+ (let loop ((total size))
+ (unless (zero? total)
+ (let ((n (get-bytevector-n! port bv 0
+ (min total (bytevector-length bv)))))
+ (loop (- total n)))))))
+
+ (fold-archive (lambda (file type content result)
+ (match type
+ ('directory
+ (format #t "D ~a~%" file))
+ ('symlink
+ (format #t "S ~a -> ~a~%" file content))
+ ((or 'regular 'executable)
+ (match content
+ ((input . size)
+ (format #t "~a ~60a ~10h B~%"
+ (if (eq? type 'executable)
+ "x" "r")
+ file size)
+ (consume-input input size))))))
+ #t
+ port
+ ""))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
(define (guix-archive . args)
(define (lines port)
;; Return lines read from PORT.
@@ -353,6 +394,8 @@ the input port."
(missing (remove (cut valid-path? store <>)
files)))
(format #t "~{~a~%~}" missing)))
+ ((assoc-ref opts 'list)
+ (list-contents (current-input-port)))
((assoc-ref opts 'extract)
=>
(lambda (target)
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index fdaeb98ad2..4c5eea05cf 100644
--- a/tests/guix-archive.sh
+++ b/tests/guix-archive.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive"
test -x "$tmpdir/bin/guile"
test -d "$tmpdir/lib/guile"
+# Check '--list'.
+guix archive -t < "$archive" | grep "^D /share/guile"
+guix archive -t < "$archive" | grep "^x /bin/guile"
+guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm"
+
if echo foo | guix archive --authorize
then false; else true; fi
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#38518] [PATCH 3/7] challenge: Report the best narinfo URI.
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 2/7] guix archive: Add '--list' Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 4/7] serialization: Remove unused procedure Ludovic Courtès
` (3 subsequent siblings)
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/scripts/substitute.scm (select-uri): Rename to...
(narinfo-best-uri): ... this, and make public. Update callers.
* guix/scripts/challenge.scm (summarize-report): Use 'narinfo-best-uri'
instead of (first (narinfo-uris ...)).
---
guix/scripts/challenge.scm | 2 +-
guix/scripts/substitute.scm | 7 ++++---
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 17e87f0291..aabb2ee549 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -192,7 +192,7 @@ inconclusive reports."
(report (G_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo)
(report (G_ " ~50a: ~a~%")
- (uri->string (first (narinfo-uris narinfo)))
+ (uri->string (narinfo-best-uri narinfo))
(hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b6034a75d2..4802fbd1fe 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -80,6 +80,7 @@
narinfo-signature
narinfo-hash->sha256
+ narinfo-best-uri
lookup-narinfos
lookup-narinfos/diverse
@@ -913,7 +914,7 @@ expected by the daemon."
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
- (let-values (((uri compression file-size) (select-uri narinfo)))
+ (let-values (((uri compression file-size) (narinfo-best-uri narinfo)))
(format #t "~a\n~a\n"
(or file-size 0)
(or (narinfo-size narinfo) 0))))
@@ -967,7 +968,7 @@ this is a rough approximation."
(_ (or (string=? compression2 "none")
(string=? compression2 "gzip")))))
-(define (select-uri narinfo)
+(define (narinfo-best-uri narinfo)
"Select the \"best\" URI to download NARINFO's nar, and return three values:
the URI, its compression method (a string), and the compressed file size."
(define choices
@@ -1008,7 +1009,7 @@ DESTINATION as a nar file. Verify the substitute against ACL."
store-item))
(let-values (((uri compression file-size)
- (select-uri narinfo)))
+ (narinfo-best-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#38518] [PATCH 4/7] serialization: Remove unused procedure.
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 2/7] guix archive: Add '--list' Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 3/7] challenge: Report the best narinfo URI Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 5/7] progress: Add 'progress-report-port' Ludovic Courtès
` (2 subsequent siblings)
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/serialization.scm (write-contents): Remove.
---
guix/serialization.scm | 18 ------------------
1 file changed, 18 deletions(-)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index cf263d321e..f793feb53d 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -199,24 +199,6 @@ substitute invalid byte sequences with question marks. This is a
(put-bytevector out buf 0 read)
(loop (- left read))))))))
-(define (write-contents file p size)
- "Write SIZE bytes from FILE to output port P."
- (define (call-with-binary-input-file file proc)
- ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
- ;; avoids any initial buffering. Disable file name canonicalization to
- ;; avoid stat'ing like crazy.
- (with-fluids ((%file-port-name-canonicalization #f))
- (let ((port (open-file file "rb")))
- (dynamic-wind
- (const #t)
- (cut proc port)
- (lambda ()
- (close-port port))))))
-
- (call-with-binary-input-file file
- (lambda (input)
- (write-contents-from-port input p size))))
-
(define (write-contents-from-port input output size)
"Write SIZE bytes from port INPUT to port OUTPUT."
(write-string "contents" output)
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#38518] [PATCH 5/7] progress: Add 'progress-report-port'.
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
` (2 preceding siblings ...)
2019-12-08 11:26 ` [bug#38518] [PATCH 4/7] serialization: Remove unused procedure Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 6/7] challenge: Add "--diff" Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 7/7] challenge: Support "--diff=diffoscope" Ludovic Courtès
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/scripts/substitute.scm (progress-report-port): Move to...
* guix/progress.scm (progress-report-port): ... here. New procedure.
---
guix/progress.scm | 31 +++++++++++++++++++++++++++++++
guix/scripts/substitute.scm | 29 -----------------------------
2 files changed, 31 insertions(+), 29 deletions(-)
diff --git a/guix/progress.scm b/guix/progress.scm
index 349637dbcf..c7567a35fd 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -40,6 +40,7 @@
progress-reporter/file
progress-reporter/bar
progress-reporter/trace
+ progress-report-port
display-download-progress
erase-current-line
@@ -342,3 +343,33 @@ should be a <progress-reporter> object."
(put-bytevector out buffer 0 bytes)
(report total)
(loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
+
+(define (progress-report-port reporter port)
+ "Return a port that continuously reports the bytes read from PORT using
+REPORTER, which should be a <progress-reporter> object."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (let* ((total 0)
+ (read! (lambda (bv start count)
+ (let ((n (match (get-bytevector-n! port bv start count)
+ ((? eof-object?) 0)
+ (x x))))
+ (set! total (+ total n))
+ (report total)
+ n))))
+ (start)
+ (make-custom-binary-input-port "progress-port-proc"
+ read! #f #f
+ (lambda ()
+ ;; XXX: Kludge! When used through
+ ;; 'decompressed-port', this port ends
+ ;; up being closed twice: once in a
+ ;; child process early on, and at the
+ ;; end in the parent process. Ignore
+ ;; the early close so we don't output
+ ;; a spurious "download-succeeded"
+ ;; trace.
+ (unless (zero? total)
+ (stop))
+ (close-port port)))))))
+
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 4802fbd1fe..7eca2c6874 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -823,35 +823,6 @@ was found."
(= (string-length file) 32)))))
(narinfo-cache-directories directory)))
-(define (progress-report-port reporter port)
- "Return a port that continuously reports the bytes read from PORT using
-REPORTER, which should be a <progress-reporter> object."
- (match reporter
- (($ <progress-reporter> start report stop)
- (let* ((total 0)
- (read! (lambda (bv start count)
- (let ((n (match (get-bytevector-n! port bv start count)
- ((? eof-object?) 0)
- (x x))))
- (set! total (+ total n))
- (report total)
- n))))
- (start)
- (make-custom-binary-input-port "progress-port-proc"
- read! #f #f
- (lambda ()
- ;; XXX: Kludge! When used through
- ;; 'decompressed-port', this port ends
- ;; up being closed twice: once in a
- ;; child process early on, and at the
- ;; end in the parent process. Ignore
- ;; the early close so we don't output
- ;; a spurious "download-succeeded"
- ;; trace.
- (unless (zero? total)
- (stop))
- (close-port port)))))))
-
(define-syntax with-networking
(syntax-rules ()
"Catch DNS lookup errors and TLS errors and gracefully exit."
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#38518] [PATCH 6/7] challenge: Add "--diff".
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
` (3 preceding siblings ...)
2019-12-08 11:26 ` [bug#38518] [PATCH 5/7] progress: Add 'progress-report-port' Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
2019-12-08 11:26 ` [bug#38518] [PATCH 7/7] challenge: Support "--diff=diffoscope" Ludovic Courtès
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/scripts/challenge.scm (dump-port*): New variable.
(archive-contents, store-item-contents, narinfo-contents)
(differing-files, report-differing-files): New procedures.
(summarize-report): Add #:report-differences and call it.
(show-help, %options): Add "--diff".
(%default-options): Add 'difference-report' key.
(report-differing-files): Parameterize CURRENT-TERMINAL-COLUMNS and pass
#:report-differences to 'summarize-report'.
* guix/tests/http.scm (%local-url): Add optional argument.
(call-with-http-server): Fix docstring typo.
* tests/challenge.scm (query-path-size, make-narinfo): New procedures.
("differing-files"): New test.
* doc/guix.texi (Invoking guix challenge): Document "--diff".
---
doc/guix.texi | 24 ++++++
guix/scripts/challenge.scm | 156 +++++++++++++++++++++++++++++++++++--
guix/tests/http.scm | 6 +-
tests/challenge.scm | 67 +++++++++++++++-
4 files changed, 242 insertions(+), 11 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 7b9aa7f7c3..9587cfad9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10297,14 +10297,23 @@ updating list of substitutes from 'https://guix.example.org'... 100.0%
local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
https://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim
+ differing files:
+ /lib/libcrypto.so.1.1
+ /lib/libssl.so.1.1
+
/gnu/store/@dots{}-git-2.5.0 contents differ:
local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f
https://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
+ differing file:
+ /libexec/git-core/git-fsck
+
/gnu/store/@dots{}-pius-2.1.1 contents differ:
local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
https://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs
+ differing file:
+ /share/man/man1/pius.1.gz
@dots{}
@@ -10390,6 +10399,21 @@ The one option that matters is:
Consider @var{urls} the whitespace-separated list of substitute source
URLs to compare to.
+@item --diff=@var{mode}
+Upon mismatches, show differences according to @var{mode}, one of:
+
+@table @asis
+@item @code{simple} (the default)
+Show the list of files that differ.
+
+@item @code{none}
+Do not show further details about the differences.
+@end table
+
+Thus, unless @code{--diff=none} is passed, @command{guix challenge}
+downloads the store items from the given substitute servers so that it
+can compare them.
+
@item --verbose
@itemx -v
Show details about matches (identical contents) in addition to
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index aabb2ee549..277eec9a5d 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -25,17 +25,23 @@
#:use-module (guix monads)
#:use-module (guix base32)
#:use-module (guix packages)
+ #:use-module (guix progress)
#:use-module (guix serialization)
#:use-module (guix scripts substitute)
#:use-module (rnrs bytevectors)
+ #:autoload (guix http-client) (http-fetch)
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module (gcrypt hash)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
#: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 (ice-9 ftw)
#:use-module (web uri)
#:export (compare-contents
@@ -49,6 +55,8 @@
comparison-report-mismatch?
comparison-report-inconclusive?
+ differing-files
+
guix-challenge))
;;; Commentary:
@@ -179,13 +187,128 @@ taken since we do not import the archives."
items
local))))
+\f
+;;;
+;;; Reporting.
+;;;
+
+(define dump-port* ;FIXME: deduplicate
+ (@@ (guix serialization) dump))
+
+(define (port-sha256* port size)
+ ;; Like 'port-sha256', but limited to SIZE bytes.
+ (let-values (((out get) (open-sha256-port)))
+ (dump-port* port out size)
+ (close-port out)
+ (get)))
+
+(define (archive-contents port)
+ "Return a list representing the files contained in the nar read from PORT."
+ (fold-archive (lambda (file type contents result)
+ (match type
+ ((or 'regular 'executable)
+ (match contents
+ ((port . size)
+ (cons `(,file ,type ,(port-sha256* port size))
+ result))))
+ ('directory result)
+ ('symlink
+ (cons `(,file ,type ,contents) result))))
+ '()
+ port
+ ""))
+
+(define (store-item-contents item)
+ "Return a list of files and contents for ITEM in the same format as
+'archive-contents'."
+ (file-system-fold (const #t) ;enter?
+ (lambda (file stat result) ;leaf
+ (define short
+ (string-drop file (string-length item)))
+
+ (match (stat:type stat)
+ ('regular
+ (let ((size (stat:size stat))
+ (type (if (zero? (logand (stat:mode stat)
+ #o100))
+ 'regular
+ 'executable)))
+ (cons `(,short ,type
+ ,(call-with-input-file file
+ (cut port-sha256* <> size)))
+ result)))
+ ('symlink
+ (cons `(,short symlink ,(readlink file))
+ result))))
+ (lambda (directory stat result) result) ;down
+ (lambda (directory stat result) result) ;up
+ (lambda (file stat result) result) ;skip
+ (lambda (file stat errno result) result) ;error
+ '()
+ item
+ lstat))
+
+(define (narinfo-contents narinfo)
+ "Fetch the nar described by NARINFO and return a list representing the file
+it contains."
+ (let*-values (((uri compression size)
+ (narinfo-best-uri narinfo))
+ ((port response)
+ (http-fetch uri)))
+ (define reporter
+ (progress-reporter/file (narinfo-path narinfo) size
+ #:abbreviation (const (uri-host uri))))
+
+ (define result
+ (call-with-decompressed-port (string->symbol compression)
+ (progress-report-port reporter port)
+ archive-contents))
+
+ (close-port port)
+ (erase-current-line (current-output-port))
+ result))
+
+(define (differing-files comparison-report)
+ "Return a list of files that differ among the nars and possibly the local
+store item specified in COMPARISON-REPORT."
+ (define contents
+ (map narinfo-contents
+ (comparison-report-narinfos comparison-report)))
+
+ (define local-contents
+ (and (comparison-report-local-sha256 comparison-report)
+ (store-item-contents (comparison-report-item comparison-report))))
+
+ (match (apply lset-difference equal?
+ (take (delete-duplicates
+ (if local-contents
+ (cons local-contents contents)
+ contents))
+ 2))
+ (((files _ ...) ...)
+ files)))
+
+(define (report-differing-files comparison-report)
+ "Report differences among the nars and possibly the local store item
+specified in COMPARISON-REPORT."
+ (match (differing-files comparison-report)
+ (()
+ #t)
+ ((files ...)
+ (format #t (N_ " differing file:~%"
+ " differing files:~%"
+ (length files)))
+ (format #t "~{ ~a~%~}" files))))
+
(define* (summarize-report comparison-report
#:key
+ (report-differences (const #f))
(hash->string bytevector->nix-base32-string)
verbose?)
- "Write to the current error port a summary of REPORT, a <comparison-report>
-object. When VERBOSE?, display matches in addition to mismatches and
-inconclusive reports."
+ "Write to the current error port a summary of COMPARISON-REPORT, a
+<comparison-report> object. When VERBOSE?, display matches in addition to
+mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES
+with COMPARISON-REPORT."
(define (report-hashes item local narinfos)
(if local
(report (G_ " local hash: ~a~%") (hash->string local))
@@ -200,7 +323,8 @@ inconclusive reports."
(match comparison-report
(($ <comparison-report> item 'mismatch local (narinfos ...))
(report (G_ "~a contents differ:~%") item)
- (report-hashes item local narinfos))
+ (report-hashes item local narinfos)
+ (report-differences comparison-report))
(($ <comparison-report> item 'inconclusive #f narinfos)
(warning (G_ "could not challenge '~a': no local build~%") item))
(($ <comparison-report> item 'inconclusive locals ())
@@ -237,6 +361,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
compare build results with those at URLS"))
(display (G_ "
-v, --verbose show details about successful comparisons"))
+ (display (G_ "
+ --diff=MODE show differences according to MODE"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
@@ -254,6 +380,18 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(lambda args
(show-version-and-exit "guix challenge")))
+ (option '("diff") #t #f
+ (lambda (opt name arg result . rest)
+ (define mode
+ (match arg
+ ("none" (const #t))
+ ("simple" report-differing-files)
+ (_ (leave (G_ "~a: unknown diff mode~%") arg))))
+
+ (apply values
+ (alist-cons 'difference-report mode result)
+ rest)))
+
(option '("substitute-urls") #t #f
(lambda (opt name arg result . rest)
(apply values
@@ -269,7 +407,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(define %default-options
`((system . ,(%current-system))
- (substitute-urls . ,%default-substitute-urls)))
+ (substitute-urls . ,%default-substitute-urls)
+ (difference-report . ,report-differing-files)))
\f
;;;
@@ -286,12 +425,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
opts))
(system (assoc-ref opts 'system))
(urls (assoc-ref opts 'substitute-urls))
+ (diff (assoc-ref opts 'difference-report))
(verbose? (assoc-ref opts 'verbose?)))
(leave-on-EPIPE
(with-store store
;; Disable grafts since substitute servers normally provide only
;; ungrafted stuff.
- (parameterize ((%graft? #f))
+ (parameterize ((%graft? #f)
+ (current-terminal-columns (terminal-columns)))
(let ((files (match files
(()
(filter (cut locally-built? store <>)
@@ -305,7 +446,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(mlet* %store-monad ((items (mapm %store-monad
ensure-store-item files))
(reports (compare-contents items urls)))
- (for-each (cut summarize-report <> #:verbose? verbose?)
+ (for-each (cut summarize-report <> #:verbose? verbose?
+ #:report-differences diff)
reports)
(report "\n")
(summarize-report-list reports)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 05ce39bca2..4119e9ce01 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -65,14 +65,14 @@ needed."
(close-port socket)
#t)))
-(define (%local-url)
+(define* (%local-url #:optional (port (%http-server-port)))
;; URL to use for 'home-page' tests.
- (string-append "http://localhost:" (number->string (%http-server-port))
+ (string-append "http://localhost:" (number->string port)
"/foo/bar"))
(define* (call-with-http-server responses+data thunk)
"Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
-requests. Each elements of RESPONSES+DATA must be a tuple containing a
+requests. Each element of RESPONSES+DATA must be a tuple containing a
response and a string, or an HTTP response code and a string."
(define responses
(map (match-lambda
diff --git a/tests/challenge.scm b/tests/challenge.scm
index c962800f3f..a2782abcbd 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,22 +18,32 @@
(define-module (test-challenge)
#:use-module (guix tests)
+ #:use-module (guix tests http)
#:use-module (gcrypt hash)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
+ #:use-module (guix serialization)
+ #:use-module (guix packages)
#:use-module (guix gexp)
+ #:use-module (guix base32)
#:use-module (guix scripts challenge)
#:use-module (guix scripts substitute)
+ #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 match))
(define query-path-hash*
(store-lift query-path-hash))
+(define (query-path-size item)
+ (mlet %store-monad ((info (query-path-info* item)))
+ (return (path-info-nar-size info))))
+
(define* (call-with-derivation-narinfo* drv thunk hash)
(lambda (store)
(with-derivation-narinfo drv (sha256 => hash)
@@ -138,7 +148,62 @@
(bytevector=? (narinfo-hash->sha256
(narinfo-hash narinfo))
hash))))))))))))
+(define (make-narinfo item size hash)
+ (format #f "StorePath: ~a
+Compression: none
+URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
+NarSize: ~d
+NarHash: sha256:~a
+References: ~%" item size (bytevector->nix-base32-string hash)))
+(test-assertm "differing-files"
+ ;; Pretend we have two different results for the same store item, ITEM,
+ ;; with "/bin/guile" differing between the two nars, and make sure
+ ;; 'differing-files' returns it.
+ (mlet* %store-monad
+ ((drv1 (package->derivation %bootstrap-guile))
+ (drv2 (gexp->derivation
+ "broken-guile"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (copy-recursively #$drv1 #$output)
+ (chmod (string-append #$output "/bin/guile")
+ #o755)
+ (call-with-output-file (string-append
+ #$output
+ "/bin/guile")
+ (lambda (port)
+ (display "corrupt!" port)))))))
+ (out1 -> (derivation->output-path drv1))
+ (out2 -> (derivation->output-path drv2))
+ (item -> (string-append (%store-prefix) "/"
+ (make-string 32 #\a) "-foo")))
+ (mbegin %store-monad
+ (built-derivations (list drv1 drv2))
+ (mlet* %store-monad ((size1 (query-path-size out1))
+ (size2 (query-path-size out2))
+ (hash1 (query-path-hash* out1))
+ (hash2 (query-path-hash* out2))
+ (nar1 -> (call-with-bytevector-output-port
+ (lambda (port)
+ (write-file out1 port))))
+ (nar2 -> (call-with-bytevector-output-port
+ (lambda (port)
+ (write-file out2 port)))))
+ (parameterize ((%http-server-port 9000))
+ (with-http-server `((200 ,(make-narinfo item size1 hash1))
+ (200 ,nar1))
+ (parameterize ((%http-server-port 9001))
+ (with-http-server `((200 ,(make-narinfo item size2 hash2))
+ (200 ,nar2))
+ (mlet* %store-monad ((urls -> (list (%local-url 9000)
+ (%local-url 9001)))
+ (reports (compare-contents (list item)
+ urls)))
+ (pk 'report reports)
+ (return (equal? (differing-files (car reports))
+ '("/bin/guile"))))))))))))
(test-end)
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#38518] [PATCH 7/7] challenge: Support "--diff=diffoscope".
2019-12-08 11:26 ` [bug#38518] [PATCH 1/7] serialization: Add 'fold-archive' Ludovic Courtès
` (4 preceding siblings ...)
2019-12-08 11:26 ` [bug#38518] [PATCH 6/7] challenge: Add "--diff" Ludovic Courtès
@ 2019-12-08 11:26 ` Ludovic Courtès
5 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-12-08 11:26 UTC (permalink / raw)
To: 38518; +Cc: Ludovic Courtès
* guix/scripts/challenge.scm (call-with-nar): New procedure.
(narinfo-contents): Express in terms of 'call-with-nar'.
(call-with-mismatches, report-differing-files/external): New
procedures.
(%diffoscope-command): New variable.
(%options): Support "diffoscope" and a string starting with "/".
* tests/challenge.scm (call-mismatch-test): New procedure.
("differing-files"): Rewrite in terms of 'call-mismatch-test'.
("call-with-mismatches"): New test.
* doc/guix.texi (Invoking guix challenge): Document it.
---
doc/guix.texi | 24 +++++++++++--
guix/scripts/challenge.scm | 70 +++++++++++++++++++++++++++++++++++---
tests/challenge.scm | 51 +++++++++++++++++++++------
3 files changed, 128 insertions(+), 17 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 9587cfad9d..b576a9fc1b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10342,8 +10342,20 @@ results, the inclusion of random numbers, and directory listings sorted
by inode number. See @uref{https://reproducible-builds.org/docs/}, for
more information.
-To find out what is wrong with this Git binary, we can do something along
-these lines (@pxref{Invoking guix archive}):
+To find out what is wrong with this Git binary, the easiest approach is
+to run:
+
+@example
+guix challenge git \
+ --diff=diffoscope \
+ --substitute-urls="https://@value{SUBSTITUTE-SERVER} https://guix.example.org"
+@end example
+
+This automatically invokes @command{diffoscope}, which displays detailed
+information about files that differ.
+
+Alternately, we can do something along these lines (@pxref{Invoking guix
+archive}):
@example
$ wget -q -O - https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0 \
@@ -10406,6 +10418,14 @@ Upon mismatches, show differences according to @var{mode}, one of:
@item @code{simple} (the default)
Show the list of files that differ.
+@item @code{diffoscope}
+@itemx @var{command}
+Invoke @uref{https://diffoscope.org/, Diffoscope}, passing it
+two directories whose contents do not match.
+
+When @var{command} is an absolute file name, run @var{command} instead
+of Diffoscope.
+
@item @code{none}
Do not show further details about the differences.
@end table
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 277eec9a5d..51e8d3e4e3 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -56,6 +56,7 @@
comparison-report-inconclusive?
differing-files
+ call-with-mismatches
guix-challenge))
@@ -248,9 +249,9 @@ taken since we do not import the archives."
item
lstat))
-(define (narinfo-contents narinfo)
- "Fetch the nar described by NARINFO and return a list representing the file
-it contains."
+(define (call-with-nar narinfo proc)
+ "Call PROC with an input port from which it can read the nar pointed to by
+NARINFO."
(let*-values (((uri compression size)
(narinfo-best-uri narinfo))
((port response)
@@ -262,12 +263,17 @@ it contains."
(define result
(call-with-decompressed-port (string->symbol compression)
(progress-report-port reporter port)
- archive-contents))
+ proc))
(close-port port)
(erase-current-line (current-output-port))
result))
+(define (narinfo-contents narinfo)
+ "Fetch the nar described by NARINFO and return a list representing the file
+it contains."
+ (call-with-nar narinfo archive-contents))
+
(define (differing-files comparison-report)
"Return a list of files that differ among the nars and possibly the local
store item specified in COMPARISON-REPORT."
@@ -300,6 +306,58 @@ specified in COMPARISON-REPORT."
(length files)))
(format #t "~{ ~a~%~}" files))))
+(define (call-with-mismatches comparison-report proc)
+ "Call PROC with two directories containing the mismatching store items."
+ (define local-hash
+ (comparison-report-local-sha256 comparison-report))
+
+ (define narinfos
+ (comparison-report-narinfos comparison-report))
+
+ (call-with-temporary-directory
+ (lambda (directory1)
+ (call-with-temporary-directory
+ (lambda (directory2)
+ (define narinfo1
+ (if local-hash
+ (find (lambda (narinfo)
+ (not (string=? (narinfo-hash narinfo)
+ local-hash)))
+ narinfos)
+ (first (comparison-report-narinfos comparison-report))))
+
+ (define narinfo2
+ (and (not local-hash)
+ (find (lambda (narinfo)
+ (not (eq? narinfo narinfo1)))
+ narinfos)))
+
+ (rmdir directory1)
+ (call-with-nar narinfo1 (cut restore-file <> directory1))
+ (when narinfo2
+ (rmdir directory2)
+ (call-with-nar narinfo2 (cut restore-file <> directory2)))
+ (proc directory1
+ (if local-hash
+ (comparison-report-item comparison-report)
+ directory2)))))))
+
+(define %diffoscope-command
+ ;; Default external diff command. Pass "--exclude-directory-metadata" so
+ ;; that the mtime/ctime differences are ignored.
+ '("diffoscope" "--exclude-directory-metadata=yes"))
+
+(define* (report-differing-files/external comparison-report
+ #:optional
+ (command %diffoscope-command))
+ "Run COMMAND to show the file-level differences for the mismatches in
+COMPARISON-REPORT."
+ (call-with-mismatches comparison-report
+ (lambda (directory1 directory2)
+ (apply system*
+ (append command
+ (list directory1 directory2))))))
+
(define* (summarize-report comparison-report
#:key
(report-differences (const #f))
@@ -386,6 +444,10 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(match arg
("none" (const #t))
("simple" report-differing-files)
+ ("diffoscope" report-differing-files/external)
+ ((and (? (cut string-prefix? "/" <>)) command)
+ (cute report-differing-files/external <>
+ (string-tokenize command)))
(_ (leave (G_ "~a: unknown diff mode~%") arg))))
(apply values
diff --git a/tests/challenge.scm b/tests/challenge.scm
index a2782abcbd..bb5633a3eb 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -29,6 +29,7 @@
#:use-module (guix base32)
#:use-module (guix scripts challenge)
#:use-module (guix scripts substitute)
+ #:use-module ((guix build utils) #:select (find-files))
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -156,10 +157,12 @@ NarSize: ~d
NarHash: sha256:~a
References: ~%" item size (bytevector->nix-base32-string hash)))
-(test-assertm "differing-files"
- ;; Pretend we have two different results for the same store item, ITEM,
- ;; with "/bin/guile" differing between the two nars, and make sure
- ;; 'differing-files' returns it.
+(define (call-mismatch-test proc)
+ "Pass PROC a <comparison-report> for a mismatch and return its return
+value."
+
+ ;; Pretend we have two different results for the same store item, ITEM, with
+ ;; "/bin/guile" differing between the two nars.
(mlet* %store-monad
((drv1 (package->derivation %bootstrap-guile))
(drv2 (gexp->derivation
@@ -178,7 +181,10 @@ References: ~%" item size (bytevector->nix-base32-string hash)))
(out1 -> (derivation->output-path drv1))
(out2 -> (derivation->output-path drv2))
(item -> (string-append (%store-prefix) "/"
- (make-string 32 #\a) "-foo")))
+ (bytevector->nix-base32-string
+ (random-bytevector 32))
+ "-foo"
+ (number->string (current-time) 16))))
(mbegin %store-monad
(built-derivations (list drv1 drv2))
(mlet* %store-monad ((size1 (query-path-size out1))
@@ -186,11 +192,11 @@ References: ~%" item size (bytevector->nix-base32-string hash)))
(hash1 (query-path-hash* out1))
(hash2 (query-path-hash* out2))
(nar1 -> (call-with-bytevector-output-port
- (lambda (port)
- (write-file out1 port))))
+ (lambda (port)
+ (write-file out1 port))))
(nar2 -> (call-with-bytevector-output-port
- (lambda (port)
- (write-file out2 port)))))
+ (lambda (port)
+ (write-file out2 port)))))
(parameterize ((%http-server-port 9000))
(with-http-server `((200 ,(make-narinfo item size1 hash1))
(200 ,nar1))
@@ -202,8 +208,31 @@ References: ~%" item size (bytevector->nix-base32-string hash)))
(reports (compare-contents (list item)
urls)))
(pk 'report reports)
- (return (equal? (differing-files (car reports))
- '("/bin/guile"))))))))))))
+ (return (proc (car reports))))))))))))
+
+(test-assertm "differing-files"
+ (call-mismatch-test
+ (lambda (report)
+ (equal? (differing-files report) '("/bin/guile")))))
+
+(test-assertm "call-with-mismatches"
+ (call-mismatch-test
+ (lambda (report)
+ (call-with-mismatches
+ report
+ (lambda (directory1 directory2)
+ (let* ((files1 (find-files directory1))
+ (files2 (find-files directory2))
+ (files (map (cute string-drop <> (string-length directory1))
+ files1)))
+ (and (equal? files
+ (map (cute string-drop <> (string-length directory2))
+ files2))
+ (equal? (remove (lambda (file)
+ (file=? (string-append directory1 "/" file)
+ (string-append directory2 "/" file)))
+ files)
+ '("/bin/guile")))))))))
(test-end)
--
2.24.0
^ permalink raw reply related [flat|nested] 13+ messages in thread