diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix-qa-frontpage/guix-data-service.scm | 22 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 305 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 20 |
4 files changed, 337 insertions, 11 deletions
diff --git a/Makefile.am b/Makefile.am index cbf3a46..b4598d9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -36,6 +36,7 @@ SOURCES = \ guix-qa-frontpage/mumi.scm \ guix-qa-frontpage/derivation-changes.scm \ guix-qa-frontpage/manage-builds.scm \ + guix-qa-frontpage/manage-patch-branches.scm \ guix-qa-frontpage/view/util.scm \ guix-qa-frontpage/view/home.scm \ guix-qa-frontpage/view/branches.scm \ diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index bde6628..3996cea 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -18,7 +18,9 @@ list-branches branch-derivation-changes-url - branch-derivation-changes)) + branch-derivation-changes + + get-latest-processed-branch-revision)) (define* (patch-series-derivation-changes-url checks #:key systems) (define comparison-check @@ -152,3 +154,21 @@ json-body))))))) #:times 6 #:delay 30)) + +(define (get-latest-processed-branch-revision branch) + (retry-on-error + (lambda () + (let-values (((response body) + (http-get (string->uri + (string-append + "https://data.qa.guix.gnu.org" + "/repository/2" + "/branch/" branch + "/latest-processed-revision.json"))))) + (let ((json-body + (json-string->scm (utf8->string body)))) + (assoc-ref + (assoc-ref json-body "revision") + "commit")))) + #:times 5 + #:delay 30)) diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm new file mode 100644 index 0000000..5e18b1e --- /dev/null +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -0,0 +1,305 @@ +(define-module (guix-qa-frontpage manage-patch-branches) + #:use-module (srfi srfi-1) + #: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* (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") + + (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) + (unless (member (number->string issue-number) + issue-numbers + string=?) + (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))))) + diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in index 53e45c2..e405c39 100644 --- a/scripts/guix-qa-frontpage.in +++ b/scripts/guix-qa-frontpage.in @@ -34,6 +34,7 @@ (prometheus) (guix-qa-frontpage database) (guix-qa-frontpage manage-builds) + (guix-qa-frontpage manage-patch-branches) (guix-qa-frontpage server)) (define %options @@ -63,7 +64,10 @@ result))) (option '("submit-builds") #f #f (lambda (opt name _ result) - (alist-cons 'submit-builds #t result))))) + (alist-cons 'submit-builds #t result))) + (option '("manage-patch-branches") #f #f + (lambda (opt name _ result) + (alist-cons 'manage-patch-branches #t result))))) (define %default-options ;; Alist of default option values @@ -79,7 +83,8 @@ dev-dir))) (database . ,(string-append (getcwd) "/guix_qa_frontpage.db")) - (submit-builds . #f))) + (submit-builds . #f) + (manage-patch-branches . #f))) (define (parse-options args) (args-fold @@ -94,14 +99,6 @@ (setvbuf (current-error-port) 'line) (let ((opts (parse-options (cdr (program-arguments))))) - (when (assq-ref opts 'repl) - ((@@ (ice-9 top-repl) call-with-sigint) - (lambda () - (with-postgresql-connection-per-thread - "repl" - start-repl))) - (exit 0)) - (let ((pid-file (assq-ref opts 'pid-file))) (when pid-file (call-with-output-file pid-file @@ -131,6 +128,9 @@ "http://127.0.0.1:8746" "https://data.qa.guix.gnu.org")) + (when (assq-ref opts 'manage-patch-branches) + (start-manage-patch-branches-thread)) + (start-guix-qa-frontpage-web-server (assq-ref opts 'port) (assq-ref opts 'host) |