Rework applying patches

To capture the output from git am.

1 files changed, 135 insertions, 109 deletions

diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 7f3adb1..f3e677c 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -7,6 +7,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 textual-ports)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (json)
@@ -23,7 +24,9 @@
   #:use-module (guix-qa-frontpage git-repository)
   #:use-module (guix-qa-frontpage patchwork)
   #:use-module (guix-qa-frontpage guix-data-service)
-  #:export (start-manage-patch-branches-thread
+  #:export (create-branch-for-issue
+
+            start-manage-patch-branches-thread
 
             get-issue-branch-base-and-target-refs))
 
@@ -33,6 +36,24 @@
                  (string-join args " "))
   (apply invoke args))
 
+(define (invoke/capture-output . args)
+  (match (pipe)
+    ((input . output)
+     (let ((pid
+            (spawn
+             (car args)
+             args
+             #:output output
+             #:error output)))
+
+       (close-port output)
+       (let ((output-string (get-string-all input)))
+         (close-port input)
+
+         (values
+          (waitpid pid)
+          output-string))))))
+
 (define (issue-numbers-for-branches)
   (define rexp
     (make-regexp "\\/issue-([0-9]*)$"))
@@ -102,85 +123,99 @@
     (close-pipe pipe)
     result))
 
-(define (create-branch-for-issue issue-number patchwork-series)
+(define (create-branch-for-issue database issue-number patchwork-series)
   (define (apply-patches)
-    (let ((series-data
-           (call-with-values
-               (lambda ()
-                 (http-get (string->uri
-                            (string-append
-                             (%patchwork-instance) "/api/1.0"
-                             "/series/" patchwork-series "/"))
-                           #:streaming? #t))
-             (lambda (response body)
-               (json->scm body)))))
-
-      (if (assoc-ref series-data "received_all")
-          (let* ((patch-data
-                  (vector->list
-                   (assoc-ref series-data "patches")))
-                 (branch-name
-                  (simple-format #f "issue-~A" issue-number))
-                 (base-tag
-                  (string-append "base-for-" branch-name)))
-
-            (simple-format #t "all patches have been received\n")
-
-            (system* "git" "tag" "--delete" base-tag)
-            (invoke "git" "tag" base-tag)
-
-            (let ((patch-ids
-                   (map
-                    (lambda (patch)
-                      (let ((name (assoc-ref patch "name"))
-                            (id   (assoc-ref patch "id")))
-
-                        (simple-format
-                         #t "Running git am \"~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))))
-
-                          (with-exception-handler
-                              (lambda (exn)
-                                (simple-format #t "exception when applying patch ~A: ~A\n"
-                                               patch-file exn)
-                                (raise-exception exn))
-                            (lambda ()
-                              (simple-format #t "applying ~A\n" patch-file)
-                              (invoke "git" "am" "--empty=drop" "--3way" patch-file))
-                            #:unwind? #t))
-                        id))
-                    patch-data)))
-
-              (let ((base-commit-hash
-                     (invoke-read-line "git" "show-ref" "--hash" base-tag))
-                    (target-commit-hash
-                     (invoke-read-line "git" "rev-parse" "HEAD")))
-
+    (define branch-name
+      (simple-format #f "issue-~A" issue-number))
+
+    (define base-tag
+      (string-append "base-for-" branch-name))
+
+    (define base-commit-hash
+      (invoke-read-line "git" "show-ref" "--hash" base-tag))
+
+    (define (create-base-tag)
+      (system* "git" "tag" "--delete" base-tag)
+      (invoke "git" "tag" base-tag))
+
+    (define (push)
+      (system* "git" "push" "--delete" "patches" base-tag)
+      (invoke "git" "push" "--verbose" "patches" base-tag)
+
+      ;; Delete the branch, to provide a clearer history
+      (system* "git" "push" "--progress" "patches" "--delete" branch-name)
+
+      (invoke "git" "push" "--progress" "-u" "patches" branch-name))
+
+    (define (clear-cache)
+      (clear-sqlite-cache-entry database
+                                'issue-branch-base-and-target-refs
+                                #:args (list issue-number))
+
+      (clear-sqlite-cache-entry database
+                                'issue-patches-overall-status
+                                #:args (list issue-number)))
+
+    (define series-data
+      (call-with-values
+          (lambda ()
+            (http-get (string->uri
+                       (string-append
+                        (%patchwork-instance) "/api/1.0"
+                        "/series/" patchwork-series "/"))
+                      #:streaming? #t))
+        (lambda (response body)
+          (json->scm body))))
+
+    (if (assoc-ref series-data "received_all")
+        (begin
+          (simple-format #t "all patches have been received\n")
+          (create-base-tag)
+
+          (let loop ((patch-data
+                      (vector->list
+                       (assoc-ref series-data "patches")))
+                     (results '()))
+            (if (null? patch-data)
                 (if (string=? base-commit-hash
-                              target-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
-                      (system* "git" "push" "--delete" "patches" base-tag)
-                      (invoke "git" "push" "--verbose" "patches" base-tag)
-
-                      ;; Delete the branch, to provide a clearer history
-                      (system* "git" "push" "--progress" "patches" "--delete" branch-name)
-
-                      (invoke "git" "push" "--progress" "-u" "patches" branch-name))))))
-
-          (begin
-            (simple-format #t "all patches have not been received, skipping\n")))))
+                      (push)
+                      (clear-cache)))
+                (let* ((patch (car patch-data))
+                       (name (assoc-ref patch "name"))
+                       (id   (assoc-ref patch "id")))
+
+                  (simple-format #t "Running git am --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" "--3way" patch-file)))
+                      (if (zero? (status:exit-val (cdr code)))
+                          (loop (cdr patch-data)
+                                `(((id . ,id)
+                                   (name . ,name)
+                                   (output . ,output))
+                                  ,@results))
+                          (begin
+                            (simple-format
+                             #t "Failed to apply \"~A.patch\" (~A)\n" id name)
+                            #f))))))))
+        (simple-format #t "all patches have not been received, skipping\n")))
 
   (let ((latest-master-commit
          (get-latest-processed-branch-revision "master")))
@@ -201,9 +236,25 @@
            (lambda (exn)
              (simple-format
               (current-error-port)
-              "exception when applying patch: ~A\n"
-              exn))
-         apply-patches
+              "exception when creating branch for ~A: ~A\n"
+              issue-number
+              exn)
+
+             (simple-format
+              (current-error-port)
+              "deleting tag and branch for issue\n")
+             (system* "git" "push" "--delete" "patches"
+                      (simple-format #f "base-for-issue-~A" issue-number))
+             (system* "git" "push" "--progress" "patches" "--delete"
+                      (simple-format #f "issue-~A" issue-number))
+
+             (raise-exception exn))
+         (lambda ()
+           (with-throw-handler #t
+             apply-patches
+             (lambda args
+               (display (backtrace) (current-error-port))
+               (newline (current-error-port)))))
          #:unwind? #t))
      #:remove-after? #t)))
 
@@ -373,40 +424,15 @@
                                     patchwork-series-time))
                           #f)))
             (simple-format #t "creating branch for issue ~A\n" issue-number)
+
             (with-exception-handler
-                (lambda (exn)
-                  (simple-format
-                   (current-error-port)
-                   "exception when creating branch for ~A: ~A\n"
-                   issue-number
-                   exn)
-
-                  (simple-format
-                   (current-error-port)
-                   "deleting tag and branch for issue\n")
-                  (system* "git" "push" "--delete" "patches"
-                           (simple-format #f "base-for-issue-~A" issue-number))
-                  (system* "git" "push" "--progress" "patches" "--delete"
-                           (simple-format #f "issue-~A" issue-number)))
+                (const #t)
               (lambda ()
-                (with-throw-handler #t
-                  (lambda ()
-                    (create-branch-for-issue issue-number
-                                             (number->string
-                                              (assoc-ref patchwork-series
-                                                         "id")))
-                    (clear-sqlite-cache-entry
-                     database
-                     'issue-branch-base-and-target-refs
-                     #:args (list issue-number))
-
-                    (clear-sqlite-cache-entry
-                     database
-                     'issue-patches-overall-status
-                     #:args (list issue-number)))
-                  (lambda args
-                    (display (backtrace) (current-error-port))
-                    (newline (current-error-port)))))
+                (create-branch-for-issue database
+                                         issue-number
+                                         (number->string
+                                          (assoc-ref patchwork-series
+                                                     "id"))))
               #:unwind? #t))))
        series-to-create-branches-for)