Improve error handling around creating patch branches

1 files changed, 132 insertions, 122 deletions

diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 70ddaff..5f2f04c 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -134,6 +134,129 @@
     result))
 
 (define (create-branch-for-issue 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")))
+
+                        (pwclient-check-create
+                         id
+                         #:context "issue"
+                         #:status "success"
+                         #:description "View issue"
+                         #:target-url (simple-format
+                                       #f "https://issues.guix.info/~A"
+                                       issue-number))
+
+                        (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)
+                                (pwclient-check-create
+                                 id
+                                 #:context "applying patch"
+                                 #:status "fail")
+
+                                (system* "git" "am" "--skip"))
+                            (lambda ()
+                              (simple-format #t "applying ~A\n" patch-file)
+                              (invoke "git" "am" "--empty=drop" "--3way" patch-file)
+
+                              (pwclient-check-create
+                               id
+                               #:context "applying patch"
+                               #:status "success"))
+                            #: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")))
+
+                (if (string=? base-commit-hash
+                              target-commit-hash)
+
+                    (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)
+
+                      (for-each
+                       (lambda (patch-id)
+                         (pwclient-check-create
+                          patch-id
+                          #:context "git-branch"
+                          #:status "success"
+                          #:description "View Git branch"
+                          #:target-url
+                          (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))
+
+                         (pwclient-check-create
+                          patch-id
+                          #:context "comparison"
+                          #:status "success"
+                          #:description "View comparision"
+                          #:target-url
+                          (simple-format #f "~A/compare?base_commit=~A&target_commit=~A"
+                                         "https://data.qa.guix.gnu.org"
+                                         base-commit-hash
+                                         target-commit-hash)))
+                       patch-ids))))))
+
+          (begin
+            (simple-format #t "all patches have not been received, skipping\n")))))
+
   (let ((latest-master-commit
          (get-latest-processed-branch-revision "master")))
 
@@ -149,128 +272,15 @@
      (simple-format #f "issue-~A" issue-number)
      latest-master-commit
      (lambda ()
-       (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")))
-
-                           (pwclient-check-create
-                            id
-                            #:context "issue"
-                            #:status "success"
-                            #:description "View issue"
-                            #:target-url (simple-format
-                                          #f "https://issues.guix.info/~A"
-                                          issue-number))
-
-                           (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)
-                                   (pwclient-check-create
-                                    id
-                                    #:context "applying patch"
-                                    #:status "fail")
-
-                                   (system* "git" "am" "--skip"))
-                               (lambda ()
-                                 (simple-format #t "applying ~A\n" patch-file)
-                                 (invoke "git" "am" "--empty=drop" "--3way" patch-file)
-
-                                 (pwclient-check-create
-                                  id
-                                  #:context "applying patch"
-                                  #:status "success"))
-                               #: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")))
-
-                   (if (string=? base-commit-hash
-                                 target-commit-hash)
-
-                       (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)
-
-                         (for-each
-                          (lambda (patch-id)
-                            (pwclient-check-create
-                             patch-id
-                             #:context "git-branch"
-                             #:status "success"
-                             #:description "View Git branch"
-                             #:target-url
-                             (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))
-
-                            (pwclient-check-create
-                             patch-id
-                             #:context "comparison"
-                             #:status "success"
-                             #:description "View comparision"
-                             #:target-url
-                             (simple-format #f "~A/compare?base_commit=~A&target_commit=~A"
-                                            "https://data.qa.guix.gnu.org"
-                                            base-commit-hash
-                                            target-commit-hash)))
-                          patch-ids))))))
-
-             (begin
-               (simple-format #t "all patches have not been received, skipping\n"))))))))
-
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format
+              (current-error-port)
+              "exception when applying patch: ~A\n"
+              exn))
+         apply-patches
+         #:unwind? #t))
+     #:remove-after? #t)))
 
 (define (start-manage-patch-branches-thread)
   (define (dig alist . parts)