summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/challenge.scm156
-rw-r--r--guix/tests/http.scm6
2 files changed, 152 insertions, 10 deletions
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))))
+
+;;;
+;;; 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 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