[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
07/09: challenge: Add "--diff".
|
From: |
guix-commits |
|
Subject: |
07/09: challenge: Add "--diff". |
|
Date: |
Thu, 12 Dec 2019 12:17:56 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit 5208db3a526e3fcdb8473d9bab8afe498c5f3f76
Author: Ludovic Courtès <address@hidden>
Date: Sat Dec 7 15:10:39 2019 +0100
challenge: Add "--diff".
* 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 cb51878..80d67a4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10321,14 +10321,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{}
@@ -10414,6 +10423,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 aabb2ee..277eec9 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))))
+
+;;;
+;;; 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)))
;;;
@@ -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 05ce39b..4119e9c 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 c962800..a2782ab 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 <address@hidden>
+;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <address@hidden>
;;;
;;; 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)
- branch master updated (336afa1 -> 16b92d0), guix-commits, 2019/12/12
- 01/09: linux-boot: Don't ignore flags when mounting root file system., guix-commits, 2019/12/12
- 02/09: serialization: Add 'fold-archive'., guix-commits, 2019/12/12
- 06/09: progress: Add 'progress-report-port'., guix-commits, 2019/12/12
- 09/09: news: Add entry for "guix challenge --diff"., guix-commits, 2019/12/12
- 04/09: challenge: Report the best narinfo URI., guix-commits, 2019/12/12
- 03/09: guix archive: Add '--list'., guix-commits, 2019/12/12
- 05/09: serialization: Remove unused procedure., guix-commits, 2019/12/12
- 08/09: challenge: Support "--diff=diffoscope"., guix-commits, 2019/12/12
- 07/09: challenge: Add "--diff".,
guix-commits <=