[no subject]

[Ludovic Courtès]

branch: master
commit df606ce4529172e6c9bcad9b71f67183dcad7d83
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Oct 18 15:00:18 2023 +0200

    templates: Provide hints for build failures.
    
    The goal is to make it easier to find the origin of a build failure.
    
    * src/cuirass/templates.scm (build-details): Add #:channels,
     #:checkouts, #:previous-checkouts, and #:first-failure.
    [build-failure-info]: New procedure.
    Use it.
    (checkout-change-table): New procedure.
    * src/cuirass/http.scm (url-handler): In “/build/ID/details”, pass extra
    arguments to ‘build-details’.
    * TODO: Update.
---
 TODO                      |  1 -
 src/cuirass/http.scm      | 25 +++++++++++++++---
 src/cuirass/templates.scm | 64 +++++++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 84 insertions(+), 6 deletions(-)

diff --git a/TODO b/TODO
index 176ec20..e752716 100644
--- a/TODO
+++ b/TODO
@@ -5,7 +5,6 @@
 
 * Allow ‘latest-channel-instances’ to time out
 * Allow builds to be retried several times
-* Display first failure on build page
 * Notify instead of polling
 
   - 'register' notifies 'remote-server' of available builds
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index fd9bb0c..4a3756b 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -813,6 +813,11 @@ passed, only display JOBS targeting this SYSTEM."
     (('GET "build" (= string->number id) "details")
      (let* ((build (and id (db-get-build id)))
             (products (and build (build-products build)))
+            (spec (and build (db-get-specification
+                              (build-specification-name build))))
+            (checkouts (and build
+                            (latest-checkouts spec
+                                              (build-evaluation-id build))))
             (dependencies
              (and build
                   (db-get-builds
@@ -825,12 +830,26 @@ passed, only display JOBS targeting this SYSTEM."
                      (oldevaluation . ,(build-evaluation-id build))
                      (status . done)
                      (order . evaluation)
-                     (nr . 10))))))
+                     (nr . 10)))))
+            (previous-checkouts
+             (match history
+               ((previous . _)
+                (latest-checkouts spec (build-evaluation-id previous)))
+               (_ '())))
+            (failure? (and build
+                           (= (build-status failed)
+                              (build-current-status build))))
+            (failure (and failure?
+                          (db-get-first-build-failure build))))
        (if build
            (respond-html
             (html-page
              (string-append "Build " (number->string id))
-             (build-details build dependencies products history)
+             (build-details build dependencies products history
+                            #:channels (specification-channels spec)
+                            #:checkouts checkouts
+                            #:previous-checkouts previous-checkouts
+                            #:first-failure failure)
              `(((#:name . ,(build-specification-name build))
                 (#:link
                  . ,(string-append "/jobset/"
@@ -1250,7 +1269,7 @@ passed, only display JOBS targeting this SYSTEM."
            (if (file-exists? file)
                (respond-file file #:ttl %static-file-ttl)
                (fail 500))                     ;something's wrong: it vanished
-           (fail 404))))                          ;no such build product
+           (fail 404))))                       ;no such build product
 
     (('GET "machine" name)
      (respond-html
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index fdf8cf1..1812820 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -665,7 +665,10 @@ the existing SPEC otherwise."
                 (div (@ (class "col-sm-10 text-warning"))
                      "Declarative configuration updates may overwrite these 
settings!"))))))
 
-(define (build-details build dependencies products history)
+(define* (build-details build dependencies products history
+                        #:key (channels '())
+                        (checkouts '()) (previous-checkouts '())
+                        first-failure)
   "Return HTML showing details for the BUILD."
   (define status (build-current-status build))
   (define weather (build-current-weather build))
@@ -695,6 +698,26 @@ the existing SPEC otherwise."
                (time->string (build-completion-time build))
                "—"))))
 
+  (define (build-failure-info build)
+    ;; If BUILD failed, provide hints as to the origin of the failure.
+    (if (= (build-status failed) (build-current-status build))
+        (if (= (build-weather new-failure) (build-current-weather build))
+            `((p "Channel changes compared to the "
+                 (a (@ (href "/build/" ,(build-id (first history)) "/details"))
+                    "previous (successful) build")
+                 ":"
+                 ,(checkout-change-table channels
+                                         previous-checkouts checkouts)))
+            (if first-failure
+                `((p "The first failure was "
+                     (a (@ (href "/build/" ,(build-id first-failure)
+                                 "/details"))
+                        "build #"
+                        ,(number->string (build-id first-failure)))
+                     "."))
+                '()))
+        '()))
+
   `((div (@ (class "d-flex flex-row mb-3"))
          (div (@ (class "lead mr-auto"))
               "Build details")
@@ -756,7 +779,8 @@ the existing SPEC otherwise."
                        (title ,(weather-title weather))
                        (aria-hidden "true"))
                     "")
-              " " ,(weather-title weather)))
+              " " ,(weather-title weather)
+              ,@(build-failure-info build)))
       (tr (th "Log file")
           (td ,(if (or (= (build-status started) status)
                        (= (build-status succeeded) status)
@@ -852,6 +876,7 @@ the existing SPEC otherwise."
                               ,(worker-machine worker))
                            ", worker " ,name)))
                  `((tr (th "Worker") (td ,name)))))))))
+
     ,@(if (null? history)
           '()
           `((div (@ (class "lead mr-auto"))
@@ -1319,6 +1344,41 @@ the nearest exact even integer."
                              (td (i "checkout information is missing")))))
                   checkouts))))
 
+(define (checkout-change-table channels old new)
+  "Return a table representing the changes from OLD to NEW, both of which are
+lists of <checkout> records.  Use CHANNELS to grab additional metadata such as
+the channel's URL."
+  `(table (@ (class "table table-sm table-hover"))
+          (tbody
+           ,@(map (lambda (checkout)
+                    (let* ((name (checkout-channel checkout))
+                           (commit (checkout-commit checkout))
+                           (previous (find (lambda (checkout)
+                                             (eq? (checkout-channel checkout)
+                                                  name))
+                                           old))
+                           (channel (find (lambda (channel)
+                                            (eq? (channel-name channel)
+                                                 name))
+                                          channels))
+                           (url (and channel (channel-url channel))))
+                      (if (string=? commit (checkout-commit previous))
+                          '()
+                          `(tr (td ,name)
+                               (td (code
+                                    ,(if url
+                                         (commit-hyperlink url
+                                                           (checkout-commit
+                                                            previous)
+                                                           #:shorten? #t)
+                                         (checkout-commit previous))
+                                    " → "
+                                    ,(if url
+                                         (commit-hyperlink url commit
+                                                           #:shorten? #t)
+                                         commit)))))))
+                  new))))
+
 (define* (build-counter-badge value class title
                               #:optional link)
   (if link