(define-module (guix-qa-frontpage manage-patch-branches) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 popen) #: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) #:use-module (prometheus) #:use-module (git) #:use-module (guix git) #:use-module (guix sets) #:use-module (guix memoization) #:use-module (guix build utils) #:use-module ((guix build syscalls) #:select (set-thread-name)) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator utils fibers) #:use-module ((guix build download) #:select (http-fetch)) #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage guix-data-service) #:export (create-branch-for-issue patchwork-series->branch start-manage-patch-branches-thread get-issue-branch-base-and-target-refs)) (define (run . args) (simple-format (current-error-port) "running: ~A\n" (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]*)$")) (with-bare-git-repository (lambda () (run "git" "fetch" "--prune" "patches") (let ((pipe (open-pipe* OPEN_READ "git" "ls-remote" "--heads" "patches"))) (let loop ((line (read-line pipe)) (branches '())) (if (eof-object? line) (begin (close-pipe pipe) (reverse branches)) (loop (read-line pipe) (match (regexp-exec rexp line) (#f branches) (issue-number-match (cons (match:substring issue-number-match 1) branches)))))))))) (define (get-issue-branch-base-and-target-refs issue) (define base-tag (string-append "base-for-issue-" (number->string issue))) (define target-branch (string-append "patches/issue-" (number->string issue))) (let ((base (get-commit base-tag)) (target (get-commit target-branch))) (and base target `((base . ,base) (target . ,target))))) (define* (pwclient-check-create patch-id #:key (project "guix-patches") status context target-url description) (apply invoke `("pwclient" "check-create" "-p" ,project "-c" ,context "-s" ,status ,(simple-format #f "~A" patch-id) ,@(if description `("-d" ,description) '()) ,@(if target-url `("-u" ,target-url) '())))) (define (invoke-read-line prog . args) (let* ((pipe (apply open-pipe* OPEN_READ prog args)) (result (read-line pipe))) (close-pipe pipe) result)) (define (parse-patch-name name) (let ((args (and (string-prefix? "[" name) (let ((stop (string-index name #\]))) (substring name 1 stop)))) (as-bug-number (lambda (arg) (and (string-prefix? "bug#" arg) (string->number (substring arg (string-length "bug#")))))) (as-v2 (lambda (arg) (and (string-prefix? "v" arg) (string->number (substring arg 1))))) (as-patch-number (lambda (arg) (match (string-split arg #\/) (((= string->number index) (= string->number total)) (and index total (<= index total) (cons index total))) (else #f))))) (let analyze ((bug-number #f) (branch "master") (version 1) (index 1) (total 1) (arguments (if args (string-split args #\,) '()))) (match arguments ((or ("") ()) `((bug-number . ,bug-number) (branch . ,branch) (version . ,version) (index . ,index) (total . ,total))) (((= as-bug-number (? number? new-bug-number)) arguments ...) (analyze new-bug-number branch version index total arguments)) (((= as-v2 (? number? new-version)) arguments ...) (analyze bug-number branch new-version index total arguments)) (((= as-patch-number ((? number? new-index) . (? number? new-total))) arguments ...) (analyze bug-number branch version new-index new-total arguments)) ((feature-branch arguments ...) (analyze bug-number feature-branch version index total arguments)))))) (define (patchwork-series->branch series) (match (assoc-ref series "patches") (#() "master") (#(first-patch rest ...) (let ((details (parse-patch-name (assoc-ref first-patch "name")))) (assq-ref details 'branch))))) (define (create-branch-for-issue database issue-number patchwork-series) (define branch-name (simple-format #f "issue-~A" issue-number)) (define base-tag (string-append "base-for-" branch-name)) (define (get-base-commit) (let ((branch (patchwork-series->branch patchwork-series))) (if (string=? branch "master") (get-latest-processed-branch-revision "master") (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) ;; 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-data #:args (list issue-number) #:version 3) (clear-sqlite-cache-entry database 'issue-patches-overall-status #:args (list issue-number))) (define (insert-log results) (define log (string-join (map (lambda (patch) (assq-ref patch 'output)) results) "\n\n")) (insert-create-branch-for-issue-log database issue-number log)) (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))))))))) (delete-create-branch-for-issue-log database 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")) (begin (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) (get-base-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 #:key series-count) (define (dig alist . parts) (if (pair? alist) (match parts ((part) (assoc-ref alist part)) ((part . rest) (if (list? alist) (apply dig (assoc-ref alist part) (cdr parts)) #f))) #f)) (define series-count-buffer 40) (define (perform-pass) (let ((issue-numbers (map string->number (issue-numbers-for-branches))) (all-patchwork-series (with-sqlite-cache database 'latest-patchwork-series-by-issue latest-patchwork-series-by-issue #:args `(#:count ,(+ series-count series-count-buffer)) #:ttl 120)) (latest-master-revision (get-latest-processed-branch-revision "master"))) ;; Several series can use the same base revision, so memoize looking up ;; the changes compared to master (define get-changes-compared-to-master (memoize (lambda (base-commit) (vector-length (assoc-ref (compare-package-derivations (compare-package-derivations-url `((base . ,base-commit) (target . ,latest-master-revision)) ;; TODO: Maybe do something smarter here? #:systems '("i686-linux"))) "derivation_changes"))))) (simple-format #t "checking for branches to delete (looking at ~A branches)\n" (length issue-numbers)) (for-each (lambda (issue-number) (when (or (if (not (mumi-issue-open? issue-number)) (begin (simple-format (current-error-port) "Removing ~A, issue closed\n" issue-number) #t) #f) (if (not (assq-ref all-patchwork-series issue-number)) (begin (simple-format (current-error-port) "Removing ~A, issue no longer in latest-patchwork-series-by-issue\n" issue-number) #t) #f) (if (string=? "master" (patchwork-series->branch (assq-ref all-patchwork-series issue-number))) (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)) ;; Don't do the following checks on changes for ;; non-master branches. #f)) (with-bare-git-repository (lambda () (let ((tag (simple-format #f "base-for-issue-~A" issue-number))) (with-exception-handler (lambda (exn) (simple-format (current-error-port) "ignoring exception when deleting tag ~A\n" tag)) (lambda () (run "git" "push" "patches" "--delete" tag)) #:unwind? #t)) (run "git" "push" "patches" "--delete" (simple-format #f "issue-~A" issue-number)))))) issue-numbers)) (simple-format #t "finished checking for branches to delete\n") (let* ((issue-numbers (map string->number (issue-numbers-for-branches))) (all-patchwork-series (with-sqlite-cache database 'latest-patchwork-series-by-issue latest-patchwork-series-by-issue #:args `(#:count ,series-count) #:ttl 120))) (for-each (match-lambda ((issue-number . patchwork-series) (when (or (not (member issue-number issue-numbers =)) ;; Does the branch need re-creating with a new series? (let ((branch-committer-date (get-git-branch-head-committer-date (simple-format #f "patches/issue-~A" issue-number))) (patchwork-series-date (assoc-ref patchwork-series "date"))) (if (and branch-committer-date patchwork-series-date) (let* ((branch-committer-time (date->time-utc branch-committer-date)) (patchwork-series-time (date->time-utc (string->date patchwork-series-date "~Y-~m-~dT~H:~M:~S"))) (recreate-branch? (time