(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
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 (create-branch-for-issue database latest-processed-master-revision
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
(assq-ref patchwork-series 'branch)))
(if (string=? branch "master")
latest-processed-master-revision
(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 base-commit-hash results)
(define log
(string-append
"Using base commit " base-commit-hash "\n\n"
(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
(stable-sort
(vector->list
(assoc-ref patchwork-series "patches"))
(lambda (patch-a patch-b)
(let ((name-a (assoc-ref patch-a "name"))
(name-b (assoc-ref patch-b "name")))
(string<? name-a name-b)))))
(results '()))
(if (null? patch-data)
(begin
(insert-log base-commit-hash 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 base-commit-hash
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))
(get-latest-processed-branch-revision*
(memoize get-latest-processed-branch-revision)))
;; Several series can use the same base revision, so memoize looking up
;; the changes compared to master
(define get-changes-compared-to-branch
(memoize
(lambda (branch base-commit)
(vector-length
(assoc-ref
(compare-package-derivations
(compare-package-derivations-url
`((base . ,base-commit)
(target . ,(get-latest-processed-branch-revision* branch)))
;; 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)
(let ((base-commit
(assq-ref
(get-issue-branch-base-and-target-refs issue-number)
'base))
(branch
(assq-ref (assq-ref all-patchwork-series issue-number)
'branch)))
(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"
"message")
(lambda (message)
(string=? message "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 (branch: ~A, base-commit: ~A): ~A\n"
branch
base-commit
exn)
#f)))
(lambda ()
(let ((derivation-change-count
(get-changes-compared-to-branch branch
base-commit)))
(if (> derivation-change-count 10000)
(begin
(simple-format
(current-error-port)
"Removing ~A, ~A derivation changes between base (~A) and latest ~A revision (~A)\n"
issue-number
derivation-change-count
base-commit
branch
(get-latest-processed-branch-revision* branch))
#t)
#f)))
#:unwind? #t)))
(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))
(latest-processed-master-revision
(get-latest-processed-branch-revision "master")))
(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<? branch-committer-time
patchwork-series-time)))
(simple-format
#t
"considering recreating branch for issue ~A (~A, ~A, ~A)\n"
issue-number
branch-committer-time
patchwork-series-time
recreate-branch?)
(time<? branch-committer-time
patchwork-series-time))
#f)))
(simple-format #t "creating branch for issue ~A\n" issue-number)
(with-exception-handler
(const #t)
(lambda ()
(create-branch-for-issue database
latest-processed-master-revision
issue-number
patchwork-series))
#:unwind? #t))))
all-patchwork-series)
(simple-format (current-error-port)
"finished processing patch branches (first: ~A, last: ~A)\n"
(car (first all-patchwork-series))
(car (last all-patchwork-series)))))
(setenv "GIT_SSH_COMMAND"
"ssh -o StrictHostKeyChecking=no")
(call-with-new-thread
(lambda ()
(catch 'system-error
(lambda ()
(set-thread-name "patch branches"))
(const #t))
(while #t
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception in manage patch branches thread: ~A\n"
exn)
(unless (worker-thread-timeout-error? exn)
(sleep 240)))
(lambda ()
(with-throw-handler #t
(lambda ()
(call-with-duration-metric
metrics-registry
"manage_patch_branches_duration_seconds"
perform-pass
#:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port))))
(sleep 3600))
#:unwind? #t)))))