Better handle patches that don't apply

4 files changed, 140 insertions, 31 deletions

diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm
index a53be99..e1a018c 100644
--- a/guix-qa-frontpage/database.scm
+++ b/guix-qa-frontpage/database.scm
@@ -45,7 +45,10 @@
 
             insert-into-builds-to-cancel-later
             delete-from-builds-to-cancel-later
-            select-from-builds-to-cancel-later))
+            select-from-builds-to-cancel-later
+
+            insert-create-branch-for-issue-log
+            select-create-branch-for-issue-log))
 
 (define-record-type <database>
   (make-database database-file reader-thread-channel writer-thread-channel
@@ -82,6 +85,11 @@ CREATE UNIQUE INDEX IF NOT EXISTS cache_idx ON cache (key);
 CREATE TABLE IF NOT EXISTS builds_to_cancel_later (
     category_name TEXT NOT NULL,
     category_value TEXT NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs (
+    issue TEXT NOT NULL,
+    log TEXT NOT NULL
 );")
 
   (sqlite-exec db schema))
@@ -110,7 +118,12 @@ CREATE TABLE IF NOT EXISTS builds_to_cancel_later (
 );
 
 CREATE UNIQUE INDEX IF NOT EXISTS builds_to_cancel_later_unique
-  ON builds_to_cancel_later (category_name, category_value);")))
+  ON builds_to_cancel_later (category_name, category_value);
+
+CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs (
+    issue TEXT NOT NULL,
+    log TEXT NOT NULL
+);")))
 
     (sqlite-finalize statement)))
 
@@ -548,3 +561,57 @@ WHERE category_name = :name"
          (sqlite-reset statement)
 
          result)))))
+
+(define (insert-create-branch-for-issue-log database issue log)
+  (database-call-with-transaction
+   database
+   (lambda (db)
+     (let ((delete-statement
+            (sqlite-prepare
+             db
+             "
+DELETE FROM create_branch_for_issue_logs WHERE issue = :issue"
+             #:cache? #t))
+           (insert-statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO create_branch_for_issue_logs (issue, log)
+VALUES (:issue, :log)"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments delete-statement
+                              #:issue issue)
+       (sqlite-step delete-statement)
+       (sqlite-reset delete-statement)
+
+       (sqlite-bind-arguments
+        insert-statement
+        #:issue issue
+        #:log log)
+
+       (sqlite-step insert-statement)
+       (sqlite-reset insert-statement)))))
+
+(define (select-create-branch-for-issue-log database issue)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT log FROM create_branch_for_issue_logs
+WHERE issue = :issue"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:issue issue)
+
+       (let ((result (match (sqlite-step statement)
+                       (#(log) log)
+                       (#f #f))))
+         (sqlite-reset statement)
+
+         result)))))
diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index f3e677c..0ce9d4b 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -167,6 +167,17 @@
         (lambda (response body)
           (json->scm body))))
 
+    (define (insert-log results)
+      (define log
+        (string-join
+         (map
+          (lambda (patch)
+            (assq-ref patch 'output))
+          results)
+         "\n\n"))
+
+      (insert-create-branch-for-issue-log database issue-number log))
+
     (if (assoc-ref series-data "received_all")
         (begin
           (simple-format #t "all patches have been received\n")
@@ -177,14 +188,17 @@
                        (assoc-ref series-data "patches")))
                      (results '()))
             (if (null? patch-data)
-                (if (string=? base-commit-hash
+                (begin
+                  (insert-log results)
+
+                  (if (string=? base-commit-hash
                               (invoke-read-line "git" "rev-parse" "HEAD"))
-                    (simple-format
-                     (current-error-port)
-                     "Commit hashes match, so no patches have been applied\n")
-                    (begin
-                      (push)
-                      (clear-cache)))
+                      (simple-format
+                       (current-error-port)
+                       "Commit hashes match, so no patches have been applied\n")
+                      (begin
+                        (push)
+                        (clear-cache))))
                 (let* ((patch (car patch-data))
                        (name (assoc-ref patch "name"))
                        (id   (assoc-ref patch "id")))
@@ -201,19 +215,22 @@
                           (dump-port port output))))
 
                     (simple-format #t "applying ~A\n" patch-file)
-                    (let ((code
-                           output
-                           (invoke/capture-output
-                            "git" "am" "--empty=drop" "--3way" patch-file)))
+                    (let* ((code
+                            output
+                            (invoke/capture-output
+                             "git" "am" "--empty=drop" "--3way" patch-file))
+                           (new-results
+                            `(((id . ,id)
+                               (name . ,name)
+                               (output . ,output))
+                              ,@results)))
                       (if (zero? (status:exit-val (cdr code)))
                           (loop (cdr patch-data)
-                                `(((id . ,id)
-                                   (name . ,name)
-                                   (output . ,output))
-                                  ,@results))
+                                new-results)
                           (begin
                             (simple-format
                              #t "Failed to apply \"~A.patch\" (~A)\n" id name)
+                            (insert-log new-results)
                             #f))))))))
         (simple-format #t "all patches have not been received, skipping\n")))
 
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 4b7bfeb..77999ba 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -431,6 +431,10 @@
                       (list (string->number number))
                       #:version 2
                       #:ttl 6000))
+                    (create-branch-for-issue-log
+                     (select-create-branch-for-issue-log
+                      database
+                      number))
                     (master-branch-substitute-availability
                      (with-sqlite-cache
                       database
@@ -449,6 +453,8 @@
                                    series
                                    (assq-ref (assq-ref series 'mumi)
                                              'tags)
+                                   base-and-target-refs
+                                   create-branch-for-issue-log
                                    (and base-and-target-refs
                                         (revision-comparison-url
                                          base-and-target-refs
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index fc5915d..0edb034 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -12,6 +12,8 @@
             issue-package-changes-view))
 
 (define (issue-view issue-number series mumi-tags
+                    base-and-target-refs
+                    create-branch-for-issue-log
                     comparison-link
                     derivation-changes
                     builds-missing?
@@ -33,18 +35,20 @@
         (a (@ (href ,(simple-format #f "https://issues.guix.gnu.org/~A"
                                     issue-number)))
            "View issue on issues.guix.gnu.org"))
-       (li
-        (a (@ (href
-               ,(let ((branch-name
-                       (simple-format #f "issue-~A" issue-number))
-                      (base-tag
-                       (simple-format #f "base-for-issue-~A" issue-number)))
-                  (simple-format
-                   #f
-                   "~A/log/?h=~A&qt=range&q=~A..~A"
-                   "https://git.guix-patches.cbaines.net/guix-patches"
-                   branch-name base-tag branch-name))))
-           "View Git branch"))
+       ,@(if base-and-target-refs
+             `((li
+                (a (@ (href
+                       ,(let ((branch-name
+                               (simple-format #f "issue-~A" issue-number))
+                              (base-tag
+                               (simple-format #f "base-for-issue-~A" issue-number)))
+                          (simple-format
+                           #f
+                           "~A/log/?h=~A&qt=range&q=~A..~A"
+                           "https://git.guix-patches.cbaines.net/guix-patches"
+                           branch-name base-tag branch-name))))
+                   "View Git branch")))
+             '())
        (li
         (a (@ (href ,(assoc-ref series "web_url")))
            "View series on Patchwork"))
@@ -236,6 +240,11 @@ td.bad {
   border: 0.3rem dashed red;
 }
 
+div.bad {
+  padding: 0.05rem 0.65rem;
+  border: 0.3rem dashed red;
+}
+
 .tag {
     display: inline-block;
     padding: 0.25em 0.4em;
@@ -267,8 +276,18 @@ td.bad {
             `(li ,(assoc-ref patch "name")))
           (assoc-ref series "patches")))
 
-      ,lint-warnings-div
-      ,package-changes-div
+      ,@(if base-and-target-refs
+            `(,lint-warnings-div
+              ,package-changes-div)
+            `((div
+               (@ (class "bad")
+                  (style "width: fit-content;"))
+               (h3 "Unable to apply "
+                   ,(if (= 0 (length (assoc-ref series "patches")))
+                        "patch"
+                        "patches"))
+               (pre ,create-branch-for-issue-log))))
+
       ,review-checklist-div
 
       (div