WIP

1 files changed, 46 insertions, 6 deletions

diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 17e87f0291..cc706d6e37 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -27,6 +27,7 @@
   #:use-module (guix packages)
   #:use-module (guix serialization)
   #:use-module (guix scripts substitute)
+  #:use-module (gnu packages)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -37,6 +38,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:use-module (web uri)
+  #:use-module (json)
   #:export (compare-contents
 
             comparison-report?
@@ -236,6 +238,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
       --substitute-urls=URLS
                          compare build results with those at URLS"))
   (display (G_ "
+      -e, --export       export results as JSON"))
+  (display (G_ "
       -v, --verbose      show details about successful comparisons"))
   (newline)
   (display (G_ "
@@ -261,6 +265,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                       (string-tokenize arg)
                                       (alist-delete 'substitute-urls result))
                           rest)))
+         (option '("export" #\e) #f #f
+                 (lambda (opt name arg result . rest)
+                   (apply values
+                          (alist-cons 'export? #t result)
+                          rest)))
          (option '("verbose" #\v) #f #f
                  (lambda (opt name arg result . rest)
                    (apply values
@@ -271,6 +280,28 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
   `((system . ,(%current-system))
     (substitute-urls . ,%default-substitute-urls)))
 
+(define (comparison-report->json comparison-report file)
+  (match comparison-report
+    (($ <comparison-report> item 'mismatch local (narinfos ...))
+     (peek (list (package-name file) 'mismatch local 'narinfos)))
+    (($ <comparison-report> item 'inconclusive #f narinfos)
+     (peek (list (package-name file) 'inconclusive #f 'narinfos)))
+    (($ <comparison-report> item 'inconclusive locals ())
+     (peek (list (package-name file) 'inconclusive #f 'narinfos)))
+    (($ <comparison-report> item 'match local (narinfos ...))
+     (peek (list (package-name file) 'match #f 'narinfos)))))
+
+(define (all-packages)
+  "Return the list of all the distro's packages."
+  (fold-packages (lambda (package result)
+                   ;; Ignore deprecated packages.
+                   (if (package-superseded package)
+                       result
+                       (cons package result)))
+                 '()
+                 #:select? (lambda (p)
+                             (not (hidden-package? p)))))
+
 
 ;;;
 ;;; Entry point.
@@ -286,6 +317,7 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                  opts))
            (system   (assoc-ref opts 'system))
            (urls     (assoc-ref opts 'substitute-urls))
+           (export?  (assoc-ref opts 'export?))
            (verbose? (assoc-ref opts 'verbose?)))
       (leave-on-EPIPE
        (with-store store
@@ -294,8 +326,10 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
          (parameterize ((%graft? #f))
            (let ((files (match files
                           (()
-                           (filter (cut locally-built? store <>)
-                                   (live-paths store)))
+                           (map package-name
+                                (all-packages)))
+                           ;; (filter (cut locally-built? store <>)
+                           ;;         (live-paths store)))
                           (x
                            files))))
              (set-build-options store
@@ -305,10 +339,16 @@ 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?)
-                           reports)
-                 (report "\n")
-                 (summarize-report-list reports)
+                 (if export?
+                     (begin
+                       (report (scm->json-string
+                                (map comparison-report->json reports files)
+                                #:pretty #t)))
+                     (begin
+                       (for-each (cut summarize-report <> #:verbose? verbose?)
+                                 reports)
+                       (report "\n")
+                       (summarize-report-list reports)))
 
                  (exit (cond ((any comparison-report-mismatch? reports) 2)
                              ((every comparison-report-match? reports) 0)