Extract out derivation changes related procedures from issue module

3 files changed, 132 insertions, 102 deletions

diff --git a/Makefile.am b/Makefile.am
index 9c1bdad..f17c5e1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -32,6 +32,7 @@ SOURCES =									\
   guix-qa-frontpage/database.scm						\
   guix-qa-frontpage/patchwork.scm						\
   guix-qa-frontpage/guix-data-service.scm					\
+  guix-qa-frontpage/derivation-changes.scm					\
   guix-qa-frontpage/manage-builds.scm						\
   guix-qa-frontpage/view/util.scm						\
   guix-qa-frontpage/view/home.scm						\
diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm
new file mode 100644
index 0000000..804fb94
--- /dev/null
+++ b/guix-qa-frontpage/derivation-changes.scm
@@ -0,0 +1,126 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-qa-frontpage derivation-changes)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (builds-by-system-excluding-cross-builds
+            categorise-builds))
+
+(define (builds-by-system-excluding-cross-builds derivation-changes side)
+  (fold (lambda (package result)
+          (fold
+           (lambda (change result)
+             (if (string=? (assoc-ref change "target")
+                           "")
+                 (let ((system (assoc-ref change "system")))
+                   `((,system
+                      . ,(append
+                          (map
+                           (lambda (build)
+                             `(,@build
+                               ("package"
+                                . (("name" . ,(assoc-ref package "name"))
+                                   ("version" . ,(assoc-ref package "version"))))))
+                           (vector->list (assoc-ref change "builds")))
+                          (or (assoc-ref result system)
+                              '())))
+                     ,@(alist-delete system result)))
+                 result))
+           result
+           (vector->list
+            (assoc-ref package side))))
+        '()
+        derivation-changes))
+
+(define (categorise-builds all-systems builds-by-system)
+  (define (package-eq? a b)
+    (and
+     (string=?
+      (assoc-ref a "name")
+      (assoc-ref b "name"))
+     (string=?
+      (assoc-ref a "version")
+      (assoc-ref b "version"))))
+
+  (define (group-builds-by-package builds)
+    (fold
+     (lambda (build result)
+       (let ((package (assoc-ref build "package")))
+         `((,package . ,(cons
+                         build
+                         (or
+                          (and=> (find (match-lambda
+                                         ((p . _)
+                                          (package-eq? p package)))
+                                       result)
+                                 cdr)
+                          '())))
+           ,@(remove
+              (match-lambda
+                ((p . _)
+                 (package-eq? p package)))
+              result))))
+     '()
+     builds))
+
+  (define systems
+    (map car builds-by-system))
+
+  (map
+   (match-lambda
+     ((system . builds)
+      (let ((builds-by-package
+             (group-builds-by-package builds)))
+        (cons
+         system
+         (fold
+          (match-lambda*
+            (((package . builds) result)
+             (let* ((build-statuses
+                     (map (lambda (build)
+                            (assoc-ref build "status"))
+                          builds))
+                    (category
+                     (cond
+                      ((member "succeeded" build-statuses)
+                       'succeeding)
+                      ((and (not (member "suceeded" build-statuses))
+                            (member "failed" build-statuses))
+                       'failing)
+                      (else
+                       'unknown))))
+
+               `((,category . ,(cons
+                                (cons package builds)
+                                (assq-ref result category)))
+                 ,@(alist-delete category result)))))
+          '((succeeding . ())
+            (failing . ())
+            (unknown . ()))
+          builds-by-package)))))
+
+   (append builds-by-system
+           (map (lambda (system)
+                  (cons system '()))
+                (filter (lambda (system)
+                          (not (member system systems)))
+                        all-systems)))))
+
+
+
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index f1ac40d..0040d59 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -2,38 +2,13 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (guix-qa-frontpage manage-builds)
+  #:use-module (guix-qa-frontpage derivation-changes)
   #:use-module (guix-qa-frontpage view util)
   #:export (issue-view))
 
 (define (issue-view issue-number series derivation-changes
                     change-details comparison-details)
 
-  (define (builds-by-system-excluding-cross-builds side)
-    (fold (lambda (package result)
-            (fold
-             (lambda (change result)
-               (if (string=? (assoc-ref change "target")
-                             "")
-                   (let ((system (assoc-ref change "system")))
-                     `((,system
-                        . ,(append
-                            (map
-                             (lambda (build)
-                               `(,@build
-                                 ("package"
-                                  . (("name" . ,(assoc-ref package "name"))
-                                     ("version" . ,(assoc-ref package "version"))))))
-                             (vector->list (assoc-ref change "builds")))
-                            (or (assoc-ref result system)
-                                '())))
-                       ,@(alist-delete system result)))
-                   result))
-             result
-             (vector->list
-              (assoc-ref package side))))
-          '()
-          derivation-changes))
-
   (define comparison-link
     (and=>
      (assoc-ref change-details "revisions")
@@ -59,80 +34,6 @@
            (simple-format #f "&build_change=~A" build-change)
            ""))))
 
-  (define (categorise-builds all-systems builds-by-system)
-    (define (package-eq? a b)
-      (and
-       (string=?
-        (assoc-ref a "name")
-        (assoc-ref b "name"))
-       (string=?
-        (assoc-ref a "version")
-        (assoc-ref b "version"))))
-
-    (define (group-builds-by-package builds)
-      (fold
-       (lambda (build result)
-         (let ((package (assoc-ref build "package")))
-           `((,package . ,(cons
-                           build
-                           (or
-                            (and=> (find (match-lambda
-                                           ((p . _)
-                                            (package-eq? p package)))
-                                         result)
-                                   cdr)
-                            '())))
-             ,@(remove
-                (match-lambda
-                  ((p . _)
-                   (package-eq? p package)))
-                result))))
-       '()
-       builds))
-
-    (define systems
-      (map car builds-by-system))
-
-    (map
-     (match-lambda
-       ((system . builds)
-        (let ((builds-by-package
-               (group-builds-by-package builds)))
-          (cons
-           system
-           (fold
-            (match-lambda*
-              (((package . builds) result)
-               (let* ((build-statuses
-                       (map (lambda (build)
-                              (assoc-ref build "status"))
-                            builds))
-                      (category
-                       (cond
-                        ((member "succeeded" build-statuses)
-                         'succeeding)
-                        ((and (not (member "suceeded" build-statuses))
-                              (member "failed" build-statuses))
-                         'failing)
-                        (else
-                         'unknown))))
-
-                 `((,category . ,(cons
-                                  (cons package builds)
-                                  (assq-ref result category)))
-                   ,@(alist-delete category result)))))
-            '((succeeding . ())
-              (failing . ())
-              (unknown . ()))
-            builds-by-package)))))
-
-     (append builds-by-system
-             (map (lambda (system)
-                    (cons system '()))
-                  (filter (lambda (system)
-                            (not (member system systems)))
-                          all-systems)))))
-
   (layout
    #:title (simple-format #f "Issue ~A" issue-number)
    #:head
@@ -243,9 +144,11 @@ td.bad {
          ,@(if (and comparison-details
                     derivation-changes)
                (let* ((base-builds
-                       (builds-by-system-excluding-cross-builds "base"))
+                       (builds-by-system-excluding-cross-builds
+                        derivation-changes "base"))
                       (target-builds
-                       (builds-by-system-excluding-cross-builds "target"))
+                       (builds-by-system-excluding-cross-builds
+                        derivation-changes "target"))
 
                       (all-systems
                        (delete-duplicates