(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 (web uri)
#:use-module (web client)
#:use-module (json)
#: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 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 (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 (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 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")))
(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)
(raise-exception exn))
(lambda ()
(simple-format #t "applying ~A\n" patch-file)
(invoke "git" "am" "--empty=drop" "--3way" patch-file))
#: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))))))
(begin
(simple-format #t "all patches have not been received, skipping\n")))))
(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 applying patch: ~A\n"
exn))
apply-patches
#:unwind? #t))
#:remove-after? #t)))
(define* (start-manage-patch-branches-thread database
#:key (series-count 200))
(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 (perform-pass)
(let ((issue-numbers
(map string->number
(issue-numbers-for-branches)))
(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)
(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 ()
(run "git" "push" "patches" "--delete"
(simple-format #f "base-for-issue-~A" issue-number))
(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* ((all-patchwork-series
(with-sqlite-cache
database
'latest-patchwork-series-by-issue
latest-patchwork-series-by-issue
#:ttl 120))
(issue-numbers
(map string->number
(issue-numbers-for-branches)))
(series-to-create-branches-for
(let ((recent-series
(take all-patchwork-series
series-count)))
(append
recent-series
(filter-map
(lambda (issue-number)
(if (assq-ref recent-series issue-number)
#f
(cons issue-number
(assq-ref all-patchwork-series
issue-number))))
issue-numbers)))))
(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
(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)))
(lambda ()
(with-throw-handler #t
(lambda ()
(create-branch-for-issue issue-number
(number->string
(assoc-ref patchwork-series
"id")))
(clear-sqlite-cache-entry
database
'issue-branch-base-and-target-refs
#:args (list issue-number))
(clear-sqlite-cache-entry
database
'issue-patches-overall-status
#:args (list issue-number)))
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port)))))))))
series-to-create-branches-for)
(simple-format (current-error-port)
"finished processing patch branches (last issue: ~A)\n"
(car (last series-to-create-branches-for)))))
(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))
(lambda ()
(with-throw-handler #t
perform-pass
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port)))))
#:unwind? #t)
(sleep 3600)))))