Change branch comparisons to work on more specific commit ranges

Rather than just comparing against the latest master revision.

This includes changes to improve request handling to the data service.

3 files changed, 270 insertions, 279 deletions

diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index 0ac3050..77a4960 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -9,7 +9,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (zlib)
   #:use-module (json)
-  #:use-module (guix-build-coordinator utils)
+  #:use-module ((guix-build-coordinator utils) #:select (retry-on-error))
   #:use-module (guix-qa-frontpage patchwork)
   #:use-module (guix-qa-frontpage manage-patch-branches)
   #:export (&guix-data-service-error
@@ -17,17 +17,15 @@
             guix-data-service-error-response-body
             guix-data-service-error-response-code
 
-            patch-series-derivation-changes-url
+            revision-derivation-changes-url
+            revision-derivation-changes
 
-            patch-series-compare-url
-            patch-series-comparison
+            revision-comparison-url
+            revision-comparison
 
             list-branches-url
             list-branches
 
-            branch-derivation-changes-url
-            derivation-changes
-
             get-latest-processed-branch-revision
 
             branch-revisions-url
@@ -48,39 +46,47 @@
   (response-body guix-data-service-error-response-body)
   (response-code guix-data-service-error-response-code))
 
-(define (guix-data-service-request url)
-  (let-values (((response body)
-                (http-get (string->uri url)
-                          #:headers
-                          '((accept-encoding . ((1 . "gzip"))))
-                          #:streaming? #t)))
-    (if (eq? (response-code response)
-             404)
-        #f
-        (let ((json-body
-               (with-exception-handler
-                   (lambda _ #f)
-                 (lambda ()
-                   (match (response-content-encoding response)
-                     (('gzip)
-                      (call-with-zlib-input-port
-                       body
-                       json->scm
-                       #:format 'gzip))
-                     (_
-                      (json->scm body))))
-                 #:unwind? #t)))
-          (if (or (> (response-code response)
-                     400)
-                  (not json-body)
-                  (assoc-ref json-body "error"))
-              (raise-exception
-               (make-guix-data-service-error json-body
-                                             (response-code response)))
-              (values json-body
-                      response))))))
-
-(define* (patch-series-derivation-changes-url base-and-target-refs #:key systems)
+(define* (guix-data-service-request url #:key (retry-times 1) (retry-delay 5))
+  (retry-on-error
+   (lambda ()
+     (let-values (((response body)
+                   (http-get (string->uri url)
+                             #:headers
+                             '((accept-encoding . ((1 . "gzip"))))
+                             #:streaming? #t)))
+       (if (eq? (response-code response)
+                404)
+           #f
+           (let ((json-body
+                  (with-exception-handler
+                      (lambda _ #f)
+                    (lambda ()
+                      (match (response-content-encoding response)
+                        (('gzip)
+                         (call-with-zlib-input-port
+                          body
+                          json->scm
+                          #:format 'gzip))
+                        (_
+                         (json->scm body))))
+                    #:unwind? #t)))
+             (if (or (> (response-code response)
+                        400)
+                     (not json-body)
+                     (assoc-ref json-body "error"))
+                 (raise-exception
+                  (make-guix-data-service-error json-body
+                                                (response-code response)))
+                 (values json-body
+                         response))))))
+   #:times retry-times
+   #:delay retry-delay
+   #:ignore (lambda (exn)
+              (and (guix-data-service-error? exn)
+                   (< (guix-data-service-error-response-code exn)
+                      500)))))
+
+(define* (revision-derivation-changes-url base-and-target-refs #:key systems)
   (string-append
    "https://data.qa.guix.gnu.org/compare/package-derivations.json?"
    "base_commit=" (assq-ref base-and-target-refs 'base)
@@ -93,7 +99,18 @@
    "&target=none"
    "&field=builds&limit_results=&all_results=on"))
 
-(define* (patch-series-compare-url base-and-target-refs #:key (json? #t))
+(define (revision-derivation-changes url)
+  (let ((json-body
+         (guix-data-service-request url)))
+    (if json-body
+        (values (vector->list
+                 (assoc-ref json-body
+                            "derivation_changes"))
+                (alist-delete "derivation_changes"
+                              json-body))
+        (values #f #f))))
+
+(define* (revision-comparison-url base-and-target-refs #:key (json? #t))
   (string-append
    "https://data.qa.guix.gnu.org/compare"
    (if json? ".json" "")
@@ -101,93 +118,30 @@
    "base_commit=" (assq-ref base-and-target-refs 'base)
    "&target_commit=" (assq-ref base-and-target-refs 'target)))
 
-(define (patch-series-comparison 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")
-                 (raise-exception
-                  (make-guix-data-service-error json-body
-                                                (response-code response)))
-                 json-body)))))
-   #:times 6
-   #:delay 5
-   #:ignore guix-data-service-error?))
+(define (revision-comparison url)
+  (guix-data-service-request url))
 
 (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")
-                 (raise-exception
-                  (make-guix-data-service-error json-body
-                                                (response-code response)))
-                 (vector->list
-                  (assoc-ref json-body "branches")))))))
-   #:times 6
-   #:delay 5))
-
-(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 (derivation-changes url)
-  (retry-on-error
-   (lambda ()
-     (let ((json-body
-            (guix-data-service-request url)))
-       (if json-body
-           (values (vector->list
-                    (assoc-ref json-body
-                               "derivation_changes"))
-                   (alist-delete "derivation_changes"
-                                 json-body))
-           (values #f #f))))
-   #:times 1
-   #:delay 5))
+  (let ((json-body
+         (guix-data-service-request url)))
+    (vector->list
+     (assoc-ref json-body "branches"))))
 
 (define (get-latest-processed-branch-revision branch)
-  (retry-on-error
-   (lambda ()
-     (let-values (((response body)
-                   (http-get (string->uri
-                              (string-append
-                               "https://data.qa.guix.gnu.org"
-                               "/repository/2"
-                               "/branch/" branch
-                               "/latest-processed-revision.json")))))
-       (let ((json-body
-              (json-string->scm (utf8->string body))))
-         (assoc-ref
-          (assoc-ref json-body "revision")
-          "commit"))))
-   #:times 5
-   #:delay 5))
+  (let ((json-body
+         (guix-data-service-request
+          (string-append
+           "https://data.qa.guix.gnu.org"
+           "/repository/2"
+           "/branch/" branch
+           "/latest-processed-revision.json"))))
+    (assoc-ref
+     (assoc-ref json-body "revision")
+     "commit")))
 
 (define (branch-revisions-url repository-id branch-name)
   (simple-format
@@ -197,23 +151,10 @@
    branch-name))
 
 (define (branch-revisions 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")
-                 (raise-exception
-                  (make-guix-data-service-error json-body
-                                                (response-code response)))
-                 (vector->list
-                  (assoc-ref json-body "revisions")))))))
-   #:times 6
-   #:delay 5))
+  (let ((json-body
+         (guix-data-service-request url)))
+    (vector->list
+     (assoc-ref json-body "revisions"))))
 
 (define* (revision-details-url commit)
   (simple-format
@@ -222,17 +163,7 @@
    commit))
 
 (define (revision-details url)
-  (let-values (((response body)
-                (http-get (string->uri url))))
-    (let ((json-body
-           (json-string->scm (utf8->string body))))
-      (if (or (> (response-code response)
-                 400)
-              (assoc-ref json-body "error"))
-          (raise-exception
-           (make-guix-data-service-error json-body
-                                         (response-code response)))
-          json-body))))
+  (guix-data-service-request url))
 
 (define* (revision-system-tests-url commit #:key (system "x86_64-linux"))
   (simple-format
@@ -242,22 +173,10 @@
    system))
 
 (define (revision-system-tests 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")
-                 (raise-exception
-                  (make-guix-data-service-error json-body))
-                 (vector->list
-                  (assoc-ref json-body "system_tests")))))))
-   #:times 6
-   #:delay 5))
+  (let ((json-body
+         (guix-data-service-request url)))
+    (vector->list
+     (assoc-ref json-body "system_tests"))))
 
 (define* (package-substitute-availability-url commit)
   (simple-format
@@ -266,12 +185,8 @@
    commit))
 
 (define (package-substitute-availability url)
-  (retry-on-error
-   (lambda ()
-     (let ((json-body
-            (guix-data-service-request url)))
-       (if json-body
-           (assoc-ref json-body "substitute_servers")
-           #f)))
-   #:times 1
-   #:delay 5))
+  (let ((json-body
+         (guix-data-service-request url)))
+    (if json-body
+        (assoc-ref json-body "substitute_servers")
+        #f)))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index b1bc946..4aa4ac8 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -117,7 +117,7 @@
           #:sxml
           (master-branch-view substitute-availability))))
       (('GET "branch" branch)
-       (let ((change-details
+       (let ((revisions
               derivation-changes-counts
               substitute-availability
               (with-sqlite-cache
@@ -130,7 +130,7 @@
          (render-html
           #:sxml
           (branch-view branch
-                       change-details
+                       revisions
                        derivation-changes-counts
                        substitute-availability))))
       (('GET "patches")
@@ -346,7 +346,7 @@
                                    (assq-ref (assq-ref series 'mumi)
                                              'tags)
                                    (and base-and-target-refs
-                                        (patch-series-compare-url
+                                        (revision-comparison-url
                                          base-and-target-refs
                                          #:json? #f))
                                    derivation-changes-counts
@@ -429,8 +429,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
 
                     (values #f #f))
                 (lambda ()
-                  (derivation-changes
-                   (patch-series-derivation-changes-url
+                  (revision-derivation-changes
+                   (revision-derivation-changes-url
                     base-and-target-refs
                     #:systems %systems-to-submit-builds-for)))
                 #:unwind? #t)
@@ -457,8 +457,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
                      #f
                      (raise-exception exn)))
              (lambda ()
-               (patch-series-comparison
-                (patch-series-compare-url
+               (revision-comparison
+                (revision-comparison-url
                  base-and-target-refs)))
              #:unwind? #t))))
 
@@ -470,32 +470,68 @@ port. Also, the port used can be changed by passing the --port option.\n"
      comparison-details)))
 
 (define* (branch-data branch-name)
-  (let* ((derivation-changes-data
-          change-details
-          (derivation-changes
-           (branch-derivation-changes-url
-            branch-name
-            #:systems %systems-to-submit-builds-for)))
+  (let* ((branch-commit
+          (get-commit
+           (string-append "origin/" branch-name)))
+         (merge-base
+          (get-git-merge-base
+           (get-commit "origin/master")
+           branch-commit))
+
+         (revisions
+          `((base   . ,merge-base)
+            (target . ,branch-commit)))
 
          (derivation-changes-counts
-          (derivation-changes-counts
-           derivation-changes-data
-           %systems-to-submit-builds-for))
+          (with-exception-handler
+              (lambda (exn)
+                (if (guix-data-service-error? exn)
+                    `((exception . guix-data-service-invalid-parameters)
+                      (invalid_query_parameters
+                       .
+                       ,(filter-map
+                         (match-lambda
+                           ((param . val)
+                            (and=>
+                             (assoc-ref val "invalid")
+                             (lambda (reason)
+                               (cons
+                                param
+                                ;; Convert the HTML error messages to something
+                                ;; easier to handle
+                                (cond
+                                 ((string-contains reason
+                                                   "failed to process revision")
+                                  'failed-to-process-revision)
+                                 ((string-contains reason
+                                                   "yet to process revision")
+                                  'yet-to-process-revision)
+                                 (else
+                                  reason)))))))
+                         (assoc-ref
+                          (guix-data-service-error-response-body exn)
+                          "query_parameters"))))
+                    `((exception . ,(simple-format #f "~A" exn)))))
+            (lambda ()
+              (let ((derivation-changes-data
+                     change-details
+                     (revision-derivation-changes
+                      (revision-derivation-changes-url
+                       revisions
+                       #:systems %systems-to-submit-builds-for))))
 
-         (target-commit
-          (assoc-ref
-           (assoc-ref
-            (assoc-ref change-details "revisions")
-            "target")
-           "commit"))
+                (derivation-changes-counts
+                 derivation-changes-data
+                 %systems-to-submit-builds-for)))
+            #:unwind? #t))
 
          (substitute-availability
           (package-substitute-availability
            (package-substitute-availability-url
-            target-commit))))
+            branch-commit))))
 
     (values
-     change-details
+     revisions
      derivation-changes-counts
      substitute-availability)))
 
@@ -699,20 +735,24 @@ port. Also, the port used can be changed by passing the --port option.\n"
 
                  #f)
              (lambda ()
-               (let ((change-details
-                      derivation-change-counts
-                      substitute-availability
-                      (with-sqlite-cache
-                       database
-                       'branch-data
-                       branch-data
-                       #:args
-                       (list branch-name)
-                       #:ttl (/ frequency 2))))
-
-                 (update-branch-substitute-availability-metrics
-                  branch-name
-                  substitute-availability)))
+               (with-throw-handler #t
+                 (lambda ()
+                   (let ((revisions
+                          derivation-change-counts
+                          substitute-availability
+                          (with-sqlite-cache
+                           database
+                           'branch-data
+                           branch-data
+                           #:args
+                           (list branch-name)
+                           #:ttl (/ frequency 2))))
+
+                     (update-branch-substitute-availability-metrics
+                      branch-name
+                      substitute-availability)))
+                 (lambda _
+                   (backtrace))))
              #:unwind? #t))
          #t)
        branches))
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index ab881cb..b6cc81f 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -9,22 +9,18 @@
 
             master-branch-view))
 
-(define (branch-view branch change-details derivation-changes-counts
+(define (branch-view branch revisions derivation-changes-counts
                      substitute-availability)
   (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)
-           ""))))
+    (string-append
+     (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
+                    (assq-ref revisions 'base)
+                    (assq-ref revisions 'target)
+                    system)
+     (if build-change
+         (simple-format #f "&build_change=~A" build-change)
+         "")))
 
   (layout
    #:title (simple-format #f "Branch ~A" branch)
@@ -47,57 +43,59 @@ td.bad {
    `((main
       (h2 "Substitute availability")
       (div
-       ,@(map
-          (lambda (details)
-            `(table
-              (thead
-               (tr
-                (th (@ (colspan 3))
-                    ,(assoc-ref
-                      (assoc-ref details "server")
-                      "url"))))
-              (tbody
-               ,@(map
-                  (lambda (system-and-target-details)
-                    (let* ((ratio
-                            (/ (assoc-ref system-and-target-details
-                                          "known")
-                               (+ (assoc-ref system-and-target-details
-                                             "known")
-                                  (assoc-ref system-and-target-details
-                                             "unknown"))))
-                           (color
-                            (cond ((> ratio 0.80) "green")
-                                  ((< ratio 0.50) "red")
-                                  (else           "orange")))
-                           (symbol
-                            (cond ((> ratio 0.80)
-                                   '(*ENTITY* "#9788"))
-                                  ((< ratio 0.50)
-                                   '(*ENTITY* "#9729"))
-                                  (else
-                                   '(*ENTITY* "#9925")))))
-                      `(tr
-                        (td
-                         (@ (style "font-family: monospace;"))
-                         ,(assoc-ref system-and-target-details
-                                     "system"))
-                        (td
-                         ,(format #f "~,1f%" (* 100. ratio)))
-                        (td (@ (style ,(string-append
-                                        "color: black;"
-                                        (if color
-                                            (simple-format
-                                             #f "background-color: ~A;" color)
-                                            ""))))
-                            ,symbol))))
-                  (filter
-                   (lambda (details)
-                     (string-null?
-                      (assoc-ref details "target")))
-                   (vector->list
-                    (assoc-ref details "availability")))))))
-          (vector->list substitute-availability)))
+       ,@(if substitute-availability
+             (map
+              (lambda (details)
+                `(table
+                  (thead
+                   (tr
+                    (th (@ (colspan 3))
+                        ,(assoc-ref
+                          (assoc-ref details "server")
+                          "url"))))
+                  (tbody
+                   ,@(map
+                      (lambda (system-and-target-details)
+                        (let* ((ratio
+                                (/ (assoc-ref system-and-target-details
+                                              "known")
+                                   (+ (assoc-ref system-and-target-details
+                                                 "known")
+                                      (assoc-ref system-and-target-details
+                                                 "unknown"))))
+                               (color
+                                (cond ((> ratio 0.80) "green")
+                                      ((< ratio 0.50) "red")
+                                      (else           "orange")))
+                               (symbol
+                                (cond ((> ratio 0.80)
+                                       '(*ENTITY* "#9788"))
+                                      ((< ratio 0.50)
+                                       '(*ENTITY* "#9729"))
+                                      (else
+                                       '(*ENTITY* "#9925")))))
+                          `(tr
+                            (td
+                             (@ (style "font-family: monospace;"))
+                             ,(assoc-ref system-and-target-details
+                                         "system"))
+                            (td
+                             ,(format #f "~,1f%" (* 100. ratio)))
+                            (td (@ (style ,(string-append
+                                            "color: black;"
+                                            (if color
+                                                (simple-format
+                                                 #f "background-color: ~A;" color)
+                                                ""))))
+                                ,symbol))))
+                      (filter
+                       (lambda (details)
+                         (string-null?
+                          (assoc-ref details "target")))
+                       (vector->list
+                        (assoc-ref details "availability")))))))
+              (vector->list substitute-availability))
+             '("Information unavailable")))
 
       (h2 "Packages")
       (div
@@ -138,7 +136,8 @@ td.bad {
                     "Unknown")
                 (th)))))
         (tbody
-         ,@(if derivation-changes-counts
+         ,@(if (and derivation-changes-counts
+                    (not (assq-ref derivation-changes-counts 'exception)))
                (if (null? derivation-changes-counts)
                    `((tr
                       (td (@ (colspan 7))
@@ -183,9 +182,46 @@ td.bad {
                                     ,(package-derivations-comparison-link system)))
                                 "View comparison")))))
                     derivation-changes-counts))
-               '((tr
-                  (td (@ (colspan 7))
-                      "Comparison unavailable")))))))))))
+               `((tr
+                  (td (@ (colspan 10))
+                      "Comparison unavailable"
+                      ,@(or (and=>
+                             (assq-ref derivation-changes-counts
+                                       'invalid_query_parameters)
+                             (lambda (params)
+                               (append-map
+                                (match-lambda
+                                  ((param . error)
+                                   (cond
+                                    ((member param '("base_commit"
+                                                     "target_commit"))
+                                     `((br)
+                                       (a
+                                        (@ (href
+                                            ,(string-append
+                                             "https://data.qa.guix.gnu.org"
+                                             "/revision/"
+                                             (assq-ref
+                                              revisions
+                                              (if (string=? param "base_commit")
+                                                  'base
+                                                  'target)))))
+                                        ,(cond
+                                          ((member error
+                                                   '(yet-to-process-revision
+                                                     failed-to-process-revision))
+                                           (simple-format
+                                            #f "~A to process ~A"
+                                            (if (eq? error 'yet-to-process-revision)
+                                                "Yet"
+                                                "Failed")
+                                            (if (string=? param "base_commit")
+                                                "base revision (from master branch)"
+                                                (string-append
+                                                 "target revision (from "
+                                                 branch " branch)")))))))))))
+                                params)))
+                            '()))))))))))))
 
 (define (master-branch-view substitute-availability)
   (layout