Adopt managing patch branches

This previously happened with some scripts run through Laminar, this commit
moves the functionality here.

2 files changed, 326 insertions, 1 deletions

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)))))
+