(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 build utils) #: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 patchwork) #:use-module (guix-qa-frontpage guix-data-service) #:export (start-manage-patch-branches-thread)) (define (with-bare-git-repository thunk) (unless (file-exists? "guix.git") (invoke "git" "clone" "--bare" "https://git.savannah.gnu.org/git/guix.git" "guix.git") (with-directory-excursion "guix.git" (invoke "git" "remote" "add" "patches" "git@git.guix-patches.cbaines.net:guix-patches") (invoke "git" "config" "user.name" "Guix Patches Tester") (invoke "git" "config" "user.email" ""))) (with-directory-excursion "guix.git" (thunk))) (define* (with-git-worktree name commit thunk #:key remove-after?) (with-bare-git-repository (lambda () (invoke "git" "worktree" "add" (string-append "../" name) "-b" name commit))) (with-directory-excursion name (thunk)) (when remove-after? (with-bare-git-repository (lambda () (system* "git" "worktree" "remove" "--force" name) (system* "git" "branch" "-D" name))))) (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-git-branch-head-committer-date branch) (with-bare-git-repository (lambda () (let ((pipe (open-pipe* OPEN_READ "git" "show" "-s" "--format=%ci" branch "--"))) (let loop ((line (read-line pipe)) (lines '())) (if (eof-object? line) (begin (close-pipe pipe) (string->date (first lines) "~Y-~m-~d ~H:~M:~S ~z")) (loop (read-line pipe) (cons line lines)))))))) (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) (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 () (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"))) (pwclient-check-create id #:context "issue" #:status "success" #:description "View issue" #:target-url (simple-format #f "https://issues.guix.info/~A" issue-number)) (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) (pwclient-check-create id #:context "applying patch" #:status "fail") (invoke "git" "am" "--skip")) (lambda () (simple-format #t "applying ~A\n" patch-file) (invoke "git" "am" "--empty=drop" "--3way" patch-file) (pwclient-check-create id #:context "applying patch" #:status "success")) #: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) (for-each (lambda (patch-id) (pwclient-check-create patch-id #:context "git-branch" #:status "success" #:description "View Git branch" #:target-url (simple-format #f "~A/log/?h=~A&qt=range&q=~A..~A" "https://git.guix-patches.cbaines.net/guix-patches" branch-name base-tag branch-name)) (pwclient-check-create patch-id #:context "comparison" #:status "success" #:description "View comparision" #:target-url (simple-format #f "~A/compare?base_commit=~A&target_commit=~A" "https://data.qa.guix.gnu.org" base-commit-hash target-commit-hash))) patch-ids)))))) (begin (simple-format #t "all patches have not been received, skipping\n")))))))) (define (start-manage-patch-branches-thread) (define (perform-pass) (let ((issue-numbers (issue-numbers-for-branches))) (with-bare-git-repository (lambda () (for-each (lambda (issue-number) (unless (mumi-issue-open? issue-number) (simple-format (current-error-port) "Removing ~A, issue closed\n" issue-number) (run "git" "push" "patches" "--delete" (string-append "base-for-issue-" issue-number)) (run "git" "push" "patches" "--delete" (string-append "issue-" issue-number)))) issue-numbers))) (for-each (match-lambda ((issue-number . patchwork-series) (when (or (not (member (number->string issue-number) issue-numbers string=?)) ;; Does the branch need re-creating with a new series? (timetime-utc (get-git-branch-head-committer-date (simple-format #f "patches/issue-~A" issue-number))) (date->time-utc (string->date (assoc-ref patchwork-series "date") "~Y-~m-~dT~H:~M:~S")))) (create-branch-for-issue issue-number (number->string (assoc-ref patchwork-series "id")))))) (take (latest-patchwork-series-by-issue) 100))) (simple-format (current-error-port) "finished processing patch branches\n") (sleep 3600)) (setenv "GIT_SSH_COMMAND" "ssh -o StrictHostKeyChecking=no") (call-with-new-thread (lambda () (while #t (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception in manage patch branches thread: ~A\n" exn)) perform-pass #:unwind? #t)))))