Start applying patches to non-master branches

If this is indicated when the patch is submitted.

1 files changed, 139 insertions, 117 deletions

diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 56f0ae6..951817f 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -175,21 +175,36 @@
         ((feature-branch arguments ...)
          (analyze bug-number feature-branch version index total arguments))))))
 
+(define (patchwork-series->branch series)
+  (let* ((first-patch
+          (vector-ref
+           (assoc-ref series "patches")
+           0))
+         (details
+          (parse-patch-name
+           (assoc-ref first-patch "name"))))
+    (assq-ref details 'branch)))
+
 (define (create-branch-for-issue database issue-number patchwork-series)
-  (define (apply-patches)
-    (define branch-name
-      (simple-format #f "issue-~A" issue-number))
+  (define branch-name
+    (simple-format #f "issue-~A" issue-number))
 
-    (define base-tag
-      (string-append "base-for-" branch-name))
+  (define base-tag
+    (string-append "base-for-" branch-name))
 
-    (define (base-commit-hash)
-      (invoke-read-line "git" "show-ref" "--hash" base-tag))
+  (define (get-base-commit)
+    (let ((branch
+           (patchwork-series->branch patchwork-series)))
+      (if (string=? branch "master")
+          (get-latest-processed-branch-revision "master")
 
-    (define (create-base-tag)
-      (system* "git" "tag" "--delete" base-tag)
-      (invoke "git" "tag" base-tag))
+          (with-bare-git-repository
+           (lambda ()
+             (invoke "git" "fetch" "--prune" "origin")
+             (invoke-read-line "git" "show-ref" "--hash"
+                               (string-append "origin/" branch)))))))
 
+  (define (apply-patches)
     (define (push)
       (system* "git" "push" "--delete" "patches" base-tag)
       (invoke "git" "push" "--verbose" "patches" base-tag)
@@ -220,67 +235,70 @@
 
       (insert-create-branch-for-issue-log database issue-number log))
 
-    (create-base-tag)
-
-    (let loop ((patch-data
-                (vector->list
-                 (assoc-ref patchwork-series "patches")))
-               (results '()))
-      (if (null? patch-data)
-          (begin
-            (insert-log results)
-
-            (if (string=? (base-commit-hash)
-                          (with-repository (getcwd) repository
-                            (oid->string
-                             (reference-name->oid repository "HEAD"))))
-                (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")))
-
-            (simple-format #t "Running git am --ignore-whitespace --empty=drop --3way \"~A.patch\" (~A)\n" id name)
-            (let ((patch-file
-                   (simple-format #f "~A.patch" id)))
-              (call-with-output-file patch-file
-                (lambda (output)
-                  (let ((port
-                         size
-                         (http-fetch
-                          (string->uri (assoc-ref patch "mbox")))))
-                    (dump-port port output))))
-
-              (simple-format #t "applying ~A\n" patch-file)
-              (let* ((code
-                      output
-                      (invoke/capture-output
-                       "git" "am"
-                       "--empty=drop"
-                       ;; As seen in #66110, there's potentially
-                       ;; something going wrong in Patchwork when
-                       ;; handling carriage return characters that need
-                       ;; to be included in the diff, but this option
-                       ;; seems to work around that
-                       "--ignore-whitespace"
-                       "--3way" patch-file))
-                     (new-results
-                      `(((id . ,id)
-                         (name . ,name)
-                         (output . ,output))
-                        ,@results)))
-                (if (zero? (status:exit-val (cdr code)))
-                    (loop (cdr patch-data)
-                          new-results)
-                    (begin
-                      (simple-format
-                       #t "Failed to apply \"~A.patch\" (~A)\n" id name)
-                      (insert-log new-results)
-                      #f))))))))
+    (system* "git" "tag" "--delete" base-tag)
+    (invoke "git" "tag" base-tag)
+    (let ((base-commit-hash
+           (invoke-read-line "git" "show-ref" "--hash" base-tag)))
+
+      (let loop ((patch-data
+                  (vector->list
+                   (assoc-ref patchwork-series "patches")))
+                 (results '()))
+        (if (null? patch-data)
+            (begin
+              (insert-log results)
+
+              (if (string=? base-commit-hash
+                            (with-repository (getcwd) repository
+                              (oid->string
+                               (reference-name->oid repository "HEAD"))))
+                  (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")))
+
+              (simple-format #t "Running git am --ignore-whitespace --empty=drop --3way \"~A.patch\" (~A)\n" id name)
+              (let ((patch-file
+                     (simple-format #f "~A.patch" id)))
+                (call-with-output-file patch-file
+                  (lambda (output)
+                    (let ((port
+                           size
+                           (http-fetch
+                            (string->uri (assoc-ref patch "mbox")))))
+                      (dump-port port output))))
+
+                (simple-format #t "applying ~A\n" patch-file)
+                (let* ((code
+                        output
+                        (invoke/capture-output
+                         "git" "am"
+                         "--empty=drop"
+                         ;; As seen in #66110, there's potentially
+                         ;; something going wrong in Patchwork when
+                         ;; handling carriage return characters that need
+                         ;; to be included in the diff, but this option
+                         ;; seems to work around that
+                         "--ignore-whitespace"
+                         "--3way" patch-file))
+                       (new-results
+                        `(((id . ,id)
+                           (name . ,name)
+                           (output . ,output))
+                          ,@results)))
+                  (if (zero? (status:exit-val (cdr code)))
+                      (loop (cdr patch-data)
+                            new-results)
+                      (begin
+                        (simple-format
+                         #t "Failed to apply \"~A.patch\" (~A)\n" id name)
+                        (insert-log new-results)
+                        #f)))))))))
 
   (if (not (assoc-ref patchwork-series "received_all"))
       (simple-format
@@ -289,9 +307,7 @@
        issue-number
        (assoc-ref patchwork-series "id"))
 
-      (let ((latest-master-commit
-             (get-latest-processed-branch-revision "master")))
-
+      (begin
         (with-bare-git-repository
          (lambda ()
            (invoke "git" "fetch" "--prune" "origin")
@@ -302,7 +318,7 @@
 
         (with-git-worktree
          (simple-format #f "issue-~A" issue-number)
-         latest-master-commit
+         (get-base-commit)
          (lambda ()
            (with-exception-handler
                (lambda (exn)
@@ -393,48 +409,54 @@
                           issue-number)
                          #t)
                        #f)
-                   (let ((base-commit
-                          (assq-ref
-                           (get-issue-branch-base-and-target-refs issue-number)
-                           'base)))
-                     (with-exception-handler
-                         (lambda (exn)
-                           (if (and (guix-data-service-error? exn)
-                                    (and=>
-                                     (dig
-                                      (guix-data-service-error-response-body exn)
-                                      "query_parameters" "base_commit"
-                                      "invalid")
-                                     (lambda (invalid)
-                                       (string=? invalid "unknown commit"))))
-                               (begin
-                                 (simple-format
-                                  (current-error-port)
-                                  "Removing ~A, base revision (~A) gone\n"
-                                  issue-number
-                                  base-commit)
-                                 #t)
-                               (begin
-                                 (simple-format
-                                  (current-error-port)
-                                  "warning: exception when fetching revision details: ~A\n"
-                                  exn)
-                                 #f)))
-                       (lambda ()
-                         (let ((derivation-change-count
-                                (get-changes-compared-to-master base-commit)))
-                           (if (> derivation-change-count 10000)
-                               (begin
-                                 (simple-format
-                                  (current-error-port)
-                                  "Removing ~A, ~A derivation changes between base (~A) and latest master revision (~A)\n"
-                                  issue-number
-                                  derivation-change-count
-                                  base-commit
-                                  latest-master-revision)
-                                 #t)
-                               #f)))
-                       #:unwind? #t)))
+                   (if (string=? "master"
+                                 (patchwork-series->branch
+                                  (assq-ref all-patchwork-series issue-number)))
+                       ;; Don't do the following checks on changes for
+                       ;; non-master branches.
+                       #f
+                       (let ((base-commit
+                              (assq-ref
+                               (get-issue-branch-base-and-target-refs issue-number)
+                               'base)))
+                         (with-exception-handler
+                             (lambda (exn)
+                               (if (and (guix-data-service-error? exn)
+                                        (and=>
+                                         (dig
+                                          (guix-data-service-error-response-body exn)
+                                          "query_parameters" "base_commit"
+                                          "invalid")
+                                         (lambda (invalid)
+                                           (string=? invalid "unknown commit"))))
+                                   (begin
+                                     (simple-format
+                                      (current-error-port)
+                                      "Removing ~A, base revision (~A) gone\n"
+                                      issue-number
+                                      base-commit)
+                                     #t)
+                                   (begin
+                                     (simple-format
+                                      (current-error-port)
+                                      "warning: exception when fetching revision details: ~A\n"
+                                      exn)
+                                     #f)))
+                           (lambda ()
+                             (let ((derivation-change-count
+                                    (get-changes-compared-to-master base-commit)))
+                               (if (> derivation-change-count 10000)
+                                   (begin
+                                     (simple-format
+                                      (current-error-port)
+                                      "Removing ~A, ~A derivation changes between base (~A) and latest master revision (~A)\n"
+                                      issue-number
+                                      derivation-change-count
+                                      base-commit
+                                      latest-master-revision)
+                                     #t)
+                                   #f)))
+                           #:unwind? #t))))
 
            (with-bare-git-repository
             (lambda ()