Generate a reproducible.json file

Which can hopefully be consumed by https://ismypackagereproducibleyet.org/

2 files changed, 76 insertions, 1 deletions

diff --git a/guix-qa-frontpage/reproducible-builds.scm b/guix-qa-frontpage/reproducible-builds.scm
new file mode 100644
index 0000000..2b4c5d5
--- /dev/null
+++ b/guix-qa-frontpage/reproducible-builds.scm
@@ -0,0 +1,70 @@
+(define-module (guix-qa-frontpage reproducible-builds)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 threads)
+  #:use-module (zlib)
+  #:use-module (json)
+  #:use-module (guix-qa-frontpage guix-data-service)
+  #:export (start-generate-reproducible.json-thread))
+
+(define* (start-generate-reproducible.json-thread)
+  (define (generate)
+    (let* ((revision (get-latest-processed-branch-revision "master"))
+           (data
+            (guix-data-service-request
+             (string-append
+              "https://data.qa.guix.gnu.org/revision/" revision
+              "/package-derivation-outputs.json?"
+              "system=x86_64-linux&target=none&field=nars"
+              "&limit_results=&all_results=on")))
+           (result
+            (vector-fold
+             (lambda (_ result output)
+               (let ((consistency
+                      (assoc-ref output "output_consistency")))
+                 (if (string=? consistency "unknown")
+                     result
+                     (let ((package (assoc-ref output "package")))
+                       (cons
+                        `((package . ,(assoc-ref package "name"))
+                          (version . ,(assoc-ref package "version"))
+                          (architecture . "x86_64-linux")
+                          (status . ,(cond
+                                      ((string=? consistency "matching")
+                                       "reproducible")
+                                      ((string=? consistency "not-matching")
+                                       "unreproducible")
+                                      (else (error "unknown consistency")))))
+                        result)))))
+             '()
+             (assoc-ref data "store_paths"))))
+
+      (call-with-output-file "reproducible.json.gz"
+        (lambda (port)
+          (call-with-zlib-output-port
+           port
+           (lambda (port)
+             (set-port-encoding! port "UTF-8")
+             (scm->json (list->vector result)
+                        port
+                        #:pretty #t))
+           #:format 'gzip)))))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format
+              (current-error-port)
+              "exception in generate reproducible.json fiber: ~A\n"
+              exn))
+         (lambda ()
+           (with-throw-handler #t
+             generate
+             (lambda args
+               (display (backtrace) (current-error-port))
+               (newline (current-error-port)))))
+         #:unwind? #t)
+       (simple-format #t "finished generating reproducible.json.gz\n")
+
+       (sleep (* 60 60 24))))))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index f401fe2..1216ed6 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -46,6 +46,7 @@
                 #:select (run-server/patched call-with-sigint))
   #:use-module (guix-qa-frontpage database)
   #:use-module (guix-qa-frontpage derivation-changes)
+  #:use-module (guix-qa-frontpage reproducible-builds)
   #:use-module (guix-qa-frontpage patchwork)
   #:use-module (guix-qa-frontpage mumi)
   #:use-module (guix-qa-frontpage debbugs)
@@ -766,11 +767,15 @@ has no patches or has been closed.")
                                   database metrics-registry
                                   #:key (controller-args '())
                                   submit-builds?
-                                  patch-issues-to-show)
+                                  patch-issues-to-show
+                                  generate-reproducible.json)
   (define controller
     (apply make-controller assets-directory database metrics-registry
            controller-args))
 
+  (when generate-reproducible.json
+    (start-generate-reproducible.json-thread))
+
   (let ((finished? (make-condition)))
     (call-with-new-thread
      (lambda ()