diff options
author | Christopher Baines <mail@cbaines.net> | 2023-10-21 15:52:58 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2023-10-21 15:56:26 +0100 |
commit | 612ec41197915e1d0cc935f4145f1fcedcd5c329 (patch) | |
tree | f5f016e001e4cf842407a0f275d36bdc1935bd31 /guix-qa-frontpage | |
parent | f12cbdb72d505690d439af054f570d93383b2689 (diff) | |
download | qa-frontpage-612ec41197915e1d0cc935f4145f1fcedcd5c329.tar qa-frontpage-612ec41197915e1d0cc935f4145f1fcedcd5c329.tar.gz |
Start applying patches to non-master branches
If this is indicated when the patch is submitted.
Diffstat (limited to 'guix-qa-frontpage')
-rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 256 |
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 () |