Start adding support for branches

7 files changed, 504 insertions, 54 deletions

diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index 96c427a..5b81379 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -12,7 +12,13 @@
             patch-series-derivation-changes
 
             patch-series-compare-url
-            patch-series-comparison))
+            patch-series-comparison
+
+            list-branches-url
+            list-branches
+
+            branch-derivation-changes-url
+            branch-derivation-changes))
 
 (define* (patch-series-derivation-changes-url series #:key systems)
   (define comparison-check
@@ -95,3 +101,57 @@
                  json-body)))))
    #:times 6
    #:delay 30))
+
+(define (list-branches-url repository-id)
+  (simple-format #f "https://data.qa.guix.gnu.org/repository/~A.json"
+                 repository-id))
+
+(define (list-branches url)
+  (retry-on-error
+   (lambda ()
+     (let-values (((response body)
+                   (http-get (string->uri url))))
+       (if (eq? (response-code response)
+                404)
+           #f
+           (let ((json-body
+                  (json-string->scm (utf8->string body))))
+             (if (assoc-ref json-body "error")
+                 #f
+                 (vector->list
+                  (assoc-ref json-body "branches")))))))
+   #:times 6
+   #:delay 30))
+
+(define* (branch-derivation-changes-url branch #:key systems)
+  (string-append
+   "https://data.qa.guix.gnu.org/compare-by-datetime/package-derivations.json?"
+   "base_branch=master"
+   "&target_branch=" branch
+   (string-join
+    (map (lambda (system)
+           (simple-format #f "&system=~A" system))
+         (or systems '()))
+    "")
+   "&target=none"
+   "&field=builds&limit_results=&all_results=on"))
+
+(define (branch-derivation-changes url)
+  (retry-on-error
+   (lambda ()
+     (let-values (((response body)
+                   (http-get (string->uri url))))
+       (if (eq? (response-code response)
+                404)
+           (values #f #f)
+           (let ((json-body
+                  (json-string->scm (utf8->string body))))
+             (if (assoc-ref json-body "error")
+                 (values #f #f)
+                 (values (vector->list
+                          (assoc-ref json-body
+                                     "derivation_changes"))
+                         (alist-delete "derivation_changes"
+                                       json-body)))))))
+   #:times 6
+   #:delay 30))
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 70bb853..fff8528 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -10,7 +10,8 @@
   #:use-module (guix-qa-frontpage guix-data-service)
   #:export (%systems-to-submit-builds-for
 
-            start-submit-patch-builds-thread))
+            start-submit-patch-builds-thread
+            start-submit-branch-builds-thread))
 
 (define %systems-to-submit-builds-for
   '("x86_64-linux"
@@ -72,6 +73,55 @@
 
        (sleep 300)))))
 
+
+(define (start-submit-branch-builds-thread database
+                                           build-coordinator
+                                           guix-data-service)
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (simple-format #t "submitting branch builds\n")
+       (let ((branches '("staging")))
+         (for-each
+          (lambda (branch)
+            (simple-format #t
+                           "considering submitting builds for branch ~A\n"
+                           branch)
+
+            (let ((derivation-changes-url
+                   (branch-derivation-changes-url branch)))
+
+              (if derivation-changes-url
+                  (let ((derivation-changes
+                         change-details
+                         (with-sqlite-cache
+                          database
+                          'branch-derivation-changes
+                          branch-derivation-changes
+                          #:args
+                          (list derivation-changes-url)
+                          #:ttl 0)))
+
+                    (when derivation-changes
+                      (let ((target-commit
+                             (assoc-ref
+                              (assoc-ref
+                               (assoc-ref change-details
+                                          "revisions")
+                               "target")
+                              "commit")))
+
+                        (submit-builds-for-branch build-coordinator
+                                                  guix-data-service
+                                                  branch
+                                                  derivation-changes
+                                                  target-commit))))
+                  (simple-format #t "no derivation changes url for branch ~A\n"
+                                 branch))))
+         branches))
+
+       (sleep 3600)))))
+
 (define* (submit-build build-coordinator guix-data-service derivation
                        #:key (priority 0) (tags '()))
   (retry-on-error
@@ -99,51 +149,58 @@
    #:times 30
    #:delay 30))
 
-(define (cancel-issue-builds-not-for-revision build-coordinator
-                                              issue
-                                              revision
-                                              derivations)
+(define (for-each-build build-coordinator proc . criteria)
   (define (builds-after id)
     (vector->list
      (assoc-ref
-      (request-builds-list build-coordinator
-                           #:tags
-                           `(((key . category)
-                              (value . package))
-                             ((key . issue)
-                              (value . ,issue)))
-                           #:not-tags
-                           `(((key . revision)
-                              (value . ,revision)))
-                           #:canceled #f
-                           #:processed #f
-                           #:limit 1000
-                           #:after-id id)
+      (apply request-builds-list
+             build-coordinator
+             (append criteria
+                     `(#:limit 1000
+                       #:after-id ,id)))
       "builds")))
 
-  (simple-format (current-error-port)
-                 "canceling builds for issue ~A and not revision ~A\n"
-                 issue
-                 revision)
   (let loop ((builds (builds-after #f)))
-    (for-each
-     (lambda (build-details)
-       (unless (member derivations
-                       (assoc-ref build-details "derivation-name"))
-         (retry-on-error
-          (lambda ()
-            (send-cancel-build-request build-coordinator
-                                       (assoc-ref build-details "uuid")))
-          #:times 6
-          #:delay 15)
-         (simple-format (current-error-port)
-                        "canceled ~A\n"
-                        (assoc-ref build-details "uuid"))))
-     builds)
+    (for-each proc builds)
     (unless (null? builds)
       (loop (builds-after
              (assoc-ref (last builds) "uuid"))))))
 
+(define (cancel-builds-not-for-revision build-coordinator
+                                        category-name
+                                        category-value
+                                        revision
+                                        derivations)
+  (simple-format (current-error-port)
+                 "canceling builds for ~A ~A and not revision ~A\n"
+                 category-name
+                 category-value
+                 revision)
+  (for-each-build
+   build-coordinator
+   (lambda (build-details)
+     (unless (member derivations
+                     (assoc-ref build-details "derivation-name"))
+       (retry-on-error
+        (lambda ()
+          (send-cancel-build-request build-coordinator
+                                     (assoc-ref build-details "uuid")))
+        #:times 6
+        #:delay 15)
+       (simple-format (current-error-port)
+                      "canceled ~A\n"
+                      (assoc-ref build-details "uuid"))))
+   #:tags
+   `(((key . category)
+      (value . package))
+     ((key . ,category-name)
+      (value . ,category-value)))
+   #:not-tags
+   `(((key . revision)
+      (value . ,revision)))
+   #:canceled #f
+   #:processed #f))
+
 (define* (submit-builds-for-issue build-coordinator
                                   guix-data-service
                                   issue
@@ -193,8 +250,61 @@
                      issue
                      target-derivations-length))
 
-  (cancel-issue-builds-not-for-revision
+  (cancel-builds-not-for-revision
    build-coordinator
+   'issue
    issue
    target-commit
    target-derivations))
+
+(define* (submit-builds-for-branch build-coordinator
+                                   guix-data-service
+                                   branch
+                                   derivation-changes
+                                   target-commit)
+  (define target-derivations
+    (fold (lambda (package result)
+            (fold
+             (lambda (change result)
+               (if (and (string=? (assoc-ref change "target")
+                                  "")
+                        (member (assoc-ref change "system")
+                                %systems-to-submit-builds-for)
+                        (eq? (vector-length
+                              (assoc-ref change "builds"))
+                             0))
+                   (cons (assoc-ref change "derivation-file-name")
+                         result)
+                   result))
+             result
+             (vector->list
+              (assoc-ref package "target"))))
+          '()
+          derivation-changes))
+  (define target-derivations-length
+    (length target-derivations))
+
+  (simple-format #t "~A target derivations for branch ~A\n"
+                 target-derivations-length
+                 branch)
+
+  (for-each (lambda (derivation)
+              (submit-build build-coordinator
+                            guix-data-service
+                            derivation
+                            #:priority -100
+                            #:tags
+                            `(((key . category)
+                               (value . package))
+                              ((key . branch)
+                               (value . ,branch))
+                              ((key . revision)
+                               (value . ,target-commit)))))
+            target-derivations)
+
+  (cancel-builds-not-for-revision
+   build-coordinator
+   'branch
+   branch
+   target-commit
+   target-derivations))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index f81265c..5fe66b0 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -35,6 +35,8 @@
   #:use-module (guix-qa-frontpage view util)
   #:use-module (guix-qa-frontpage view home)
   #:use-module (guix-qa-frontpage view patches)
+  #:use-module (guix-qa-frontpage view branches)
+  #:use-module (guix-qa-frontpage view branch)
   #:use-module (guix-qa-frontpage view issue)
   #:export (start-guix-qa-frontpage-web-server))
 
@@ -62,6 +64,34 @@
        (or (handle-static-assets (string-join rest "/")
                                  (request-headers request))
            (not-found (request-uri request))))
+      (('GET "branches")
+       (let ((branches
+              (with-sqlite-cache
+               database
+               'branches
+               (lambda ()
+                 (list-branches
+                  (list-branches-url 2)))
+               #:ttl 60)))
+         (render-html
+          #:sxml
+          (branches-view branches))))
+      (('GET "branch" branch)
+       (let ((derivation-changes
+              change-details
+              (with-sqlite-cache
+               database
+               'branch-derivation-changes
+               branch-derivation-changes
+               #:args
+               (list (branch-derivation-changes-url
+                      branch
+                      #:systems %systems-to-submit-builds-for))
+               #:ttl 6000)))
+         (render-html
+          #:sxml
+          (branch-view branch
+                       derivation-changes))))
       (('GET "patches")
        (let ((latest-series
               (with-sqlite-cache
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
new file mode 100644
index 0000000..c68a1b9
--- /dev/null
+++ b/guix-qa-frontpage/view/branch.scm
@@ -0,0 +1,239 @@
+(define-module (guix-qa-frontpage view branch)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (guix-qa-frontpage manage-builds)
+  #:use-module (guix-qa-frontpage view util)
+  #:export (branch-view))
+
+(define (branch-view branch derivation-changes)
+  (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* (package-derivations-comparison-link system
+                                                #:key build-change)
+    (let ((revisions
+           (assoc-ref change-details "revisions")))
+      (string-append
+       (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
+                      (assoc-ref (assoc-ref revisions "base")
+                                 "commit")
+                      (assoc-ref (assoc-ref revisions "target")
+                                 "commit")
+                      system)
+       (if build-change
+           (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 "Branch ~A" branch)
+   #:body
+   `((main
+
+
+      (div
+       (table
+        (@ (style "border-collapse: collapse;"))
+        (thead
+         (tr
+          (th (@ (rowspan 3)) "System")
+          (th (@ (colspan 6)) "Package build status")
+          (th))
+         (tr
+          (th (@ (colspan 3)) "Base")
+          (th (@ (colspan 3)) "With patches applied")
+          (th))
+         (tr
+          (th (@ (style "min-width: 5rem;"))
+              "Succeeding")
+          (th (@ (style "min-width: 5rem;"))
+              "Failing")
+          (th (@ (style "min-width: 5rem;"))
+              "Unknown")
+          (th (@ (style "min-width: 5rem;"))
+              "Succeeding")
+          (th (@ (style "min-width: 5rem;"))
+              "Failing")
+          (th (@ (style "min-width: 5rem;"))
+              "Unknown")
+          (th)))
+        (tbody
+         ,@(if derivation-changes
+               (let* ((base-builds
+                       (builds-by-system-excluding-cross-builds "base"))
+                      (target-builds
+                       (builds-by-system-excluding-cross-builds "target"))
+
+                      (all-systems
+                       (delete-duplicates
+                        (append (map car base-builds)
+                                (map car target-builds))))
+
+                      (categorised-base-builds-by-system
+                       (categorise-builds all-systems base-builds))
+                      (categorised-target-builds-by-system
+                       (categorise-builds all-systems target-builds)))
+
+                 (if (null? target-builds)
+                     `((tr
+                        (td (@ (colspan 7))
+                            "No package derivation changes")))
+                     (map
+                      (match-lambda
+                        ((system . categorised-target-builds)
+                         (let ((categorised-base-builds
+                                (assoc-ref categorised-base-builds-by-system
+                                           system))
+                               (highlighed-common
+                                " "))
+                           (define (count side status)
+                             (length
+                              (assoc-ref
+                               (if (eq? side 'base)
+                                   categorised-base-builds
+                                   categorised-target-builds)
+                               status)))
+
+                           `(tr
+                             (td (@ (class "monospace")) ,system)
+                             ,@(map (lambda (status)
+                                      `(td ,(count 'base status)))
+                                    '(succeeding failing unknown))
+                             (td ,@(if (and (>= (count 'target 'succeeding)
+                                                (count 'base 'succeeding))
+                                            (> (count 'target 'succeeding)
+                                               0))
+                                       `((@ (class "good")))
+                                       '())
+                                 ,(count 'target 'succeeding))
+                             ,(if (> (count 'target 'failing)
+                                     (count 'base 'failing))
+                                  `(td (@ (class "bad"))
+                                       (a ;; (@ (href ,(package-derivations-comparison-link
+                                          ;;            system
+                                          ;;            #:build-change "broken")))
+                                          ,(count 'target 'failing)))
+                                  `(td ,(count 'target 'failing)))
+                             ,(if (> (count 'target 'unknown)
+                                     (count 'base 'unknown))
+                                  `(td (@ (class "bad"))
+                                       (a ;; (@ (href ,(package-derivations-comparison-link
+                                          ;;            system
+                                          ;;            #:build-change "unknown")))
+                                          ,(count 'target 'unknown)))
+                                  `(td ,(count 'target 'unknown)))
+                             (td (a ;; (@ (href
+                                    ;;     ,(package-derivations-comparison-link system)))
+                                    "View comparison"))))))
+                      (sort
+                       categorised-target-builds-by-system
+                       (lambda (a b)
+                         (< (or (list-index
+                                 (lambda (s)
+                                   (string=? (car a) s))
+                                 %systems-to-submit-builds-for)
+                                10)
+                            (or (list-index
+                                 (lambda (s)
+                                   (string=? (car b) s))
+                                 %systems-to-submit-builds-for)
+                                10)))))))
+               '((tr
+                  (td (@ (colspan 7))
+                      "Comparison unavailable")))))))))))
diff --git a/guix-qa-frontpage/view/branches.scm b/guix-qa-frontpage/view/branches.scm
new file mode 100644
index 0000000..90d1da7
--- /dev/null
+++ b/guix-qa-frontpage/view/branches.scm
@@ -0,0 +1,19 @@
+(define-module (guix-qa-frontpage view branches)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (guix-qa-frontpage view util)
+  #:export (branches-view))
+
+(define (branches-view branches)
+  (layout
+   #:title "Branches"
+   #:body
+   `((main
+      (table
+       (tbody
+        ,@(map (lambda (branch-details)
+                 (let ((name (assoc-ref branch-details "name")))
+                   `(tr
+                     (td (a (@ (href ,(simple-format #f "/branch/~A" name)))
+                            ,name)))))
+               branches)))))))
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index d3badff..2634aec 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -89,17 +89,6 @@
        '()
        builds))
 
-    (define (filter-package-builds-by-status builds-by-package statuses)
-      (filter
-       (match-lambda
-         ((package . builds)
-          (find
-           (lambda (build)
-             (member (assoc-ref build "status")
-                     statuses))
-           builds)))
-       builds-by-package))
-
     (define systems
       (map car builds-by-system))
 
diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
index 904875c..3a8451d 100644
--- a/scripts/guix-qa-frontpage.in
+++ b/scripts/guix-qa-frontpage.in
@@ -61,9 +61,9 @@
                   (alist-cons 'database
                               arg
                               result)))
-        (option '("submit-builds-for-patches") #f #f
+        (option '("submit-builds") #f #f
                 (lambda (opt name _ result)
-                  (alist-cons 'submit-builds-for-patches #t result)))))
+                  (alist-cons 'submit-builds #t result)))))
 
 (define %default-options
   ;; Alist of default option values
@@ -79,7 +79,7 @@
                                 dev-dir)))
     (database . ,(string-append (getcwd)
                                 "/guix_qa_frontpage.db"))
-    (submit-builds-for-patches . #f)))
+    (submit-builds . #f)))
 
 (define (parse-options args)
   (args-fold
@@ -121,10 +121,13 @@
           (setup-database (assq-ref opts 'database)
                           metrics-registry)))
 
-    (when (assq-ref opts 'submit-builds-for-patches)
+    (when (assq-ref opts 'submit-builds)
       (start-submit-patch-builds-thread database
                                         "http://127.0.0.1:8746"
-                                        "https://data.qa.guix.gnu.org"))
+                                        "https://data.qa.guix.gnu.org")
+      (start-submit-branch-builds-thread database
+                                         "http://127.0.0.1:8746"
+                                         "https://data.qa.guix.gnu.org"))
 
     (start-guix-qa-frontpage-web-server
      (assq-ref opts 'port)