From f12cbdb72d505690d439af054f570d93383b2689 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 21 Oct 2023 15:17:29 +0100 Subject: Check if all patches have been received earlier --- guix-qa-frontpage/manage-patch-branches.scm | 209 ++++++++++++++-------------- 1 file changed, 104 insertions(+), 105 deletions(-) diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index 616a300..56f0ae6 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -220,116 +220,115 @@ (insert-create-branch-for-issue-log database issue-number log)) - (if (assoc-ref patchwork-series "received_all") - (begin - (simple-format #t "all patches have been received\n") - (create-base-tag) - - (let loop ((patch-data - (vector->list - (assoc-ref patchwork-series "patches"))) - (results '())) - (if (null? patch-data) + (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 - (insert-log results) - - (if (string=? (base-commit-hash) - (with-repository (getcwd) repository - (oid->string - (reference-name->oid repository "HEAD")))) + (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 - (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)))))))) - (simple-format - #t - "issue ~A (series: ~A): all patches have not been received, skipping\n" - issue-number - (assoc-ref patchwork-series "id")))) - - (let ((latest-master-commit - (get-latest-processed-branch-revision "master"))) - - (with-bare-git-repository - (lambda () - (invoke "git" "fetch" "--prune" "origin") - (system* "git" "worktree" "remove" "--force" - (simple-format #f "../issue-~A" issue-number)) - (system* "git" "branch" "-D" - (simple-format #f "issue-~A" issue-number)))) - - (with-git-worktree - (simple-format #f "issue-~A" issue-number) - latest-master-commit - (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception when creating branch for ~A: ~A\n" - issue-number - exn) + #t "Failed to apply \"~A.patch\" (~A)\n" id name) + (insert-log new-results) + #f)))))))) - (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)) + (if (not (assoc-ref patchwork-series "received_all")) + (simple-format + #t + "issue ~A (series: ~A): all patches have not been received, skipping\n" + issue-number + (assoc-ref patchwork-series "id")) + + (let ((latest-master-commit + (get-latest-processed-branch-revision "master"))) - (raise-exception exn)) + (with-bare-git-repository (lambda () - (with-throw-handler #t - apply-patches - (lambda args - (display (backtrace) (current-error-port)) - (newline (current-error-port))))) - #:unwind? #t)) - #:remove-after? #t))) + (invoke "git" "fetch" "--prune" "origin") + (system* "git" "worktree" "remove" "--force" + (simple-format #f "../issue-~A" issue-number)) + (system* "git" "branch" "-D" + (simple-format #f "issue-~A" issue-number)))) + + (with-git-worktree + (simple-format #f "issue-~A" issue-number) + latest-master-commit + (lambda () + (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)) + + (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)))) (define* (start-manage-patch-branches-thread database metrics-registry -- cgit v1.2.3