ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

challenge: Add "--diff".

Browse source 
* 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".
This commit is contained in:
Ludovic Courtès 2019-12-07 15:10:39 +01:00
parent 22f06a2128
commit 5208db3a52
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
4 changed files with 242 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
doc/guix.texi
View file

@ -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

156
guix/scripts/challenge.scm
View file

@ -25,17 +25,23 @@ (define-module (guix scripts challenge)
#: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 @@ (define-module (guix scripts challenge)
comparison-report-mismatch?
comparison-report-inconclusive?
differing-files
guix-challenge))
;;; Commentary:
@ -179,13 +187,128 @@ (define (select-reference item narinfos urls)
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 @@ (define (report-hashes item local narinfos)
(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 @@ (define (show-help)
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 @@ (define %options
(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 @@ (define %options
(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 @@ (define (guix-challenge . args)
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 @@ (define (guix-challenge . args)
(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)

6
guix/tests/http.scm
View file

@ -65,14 +65,14 @@ (define (http-server-can-listen?)
(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

67
tests/challenge.scm
View file

@ -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 @@ (define-syntax with-derivation-narinfo*
(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)