diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix-qa-frontpage/git-repository.scm | 102 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 54 |
3 files changed, 104 insertions, 53 deletions
diff --git a/Makefile.am b/Makefile.am index b4598d9..711d842 100644 --- a/Makefile.am +++ b/Makefile.am @@ -37,6 +37,7 @@ SOURCES = \ guix-qa-frontpage/derivation-changes.scm \ guix-qa-frontpage/manage-builds.scm \ guix-qa-frontpage/manage-patch-branches.scm \ + guix-qa-frontpage/git-repository.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/git-repository.scm b/guix-qa-frontpage/git-repository.scm new file mode 100644 index 0000000..5ae2d56 --- /dev/null +++ b/guix-qa-frontpage/git-repository.scm @@ -0,0 +1,102 @@ +(define-module (guix-qa-frontpage git-repository) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) + #:use-module (ice-9 exceptions) + #:use-module (git) + #:use-module (git rev-parse) + #:use-module (git object) + #:use-module (git oid) + #:use-module (git structs) + #:use-module (guix build utils) + #:use-module ((guix build utils) #:select (with-directory-excursion)) + #:export (ensure-repository-exists! + update-repository! + with-bare-git-repository + with-git-worktree + + get-commit + + get-git-branch-head-committer-date)) + +(define (ensure-repository-exists!) + (monitor + (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" ""))))) + +(define (update-repository!) + (with-bare-git-repository + (lambda () + (invoke "git" "fetch" "--prune" "origin") + (invoke "git" "fetch" "--prune" "patches")))) + +(define (with-bare-git-repository thunk) + (ensure-repository-exists!) + + (monitor + (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 (get-commit ref) + (ensure-repository-exists!) + + (with-exception-handler + (lambda (exn) + (if (and (exception-with-irritants? exn) + (let ((irritant (first (exception-irritants exn)))) + (and (git-error? irritant) + (= (git-error-code irritant) -3)))) + #f + (raise-exception exn))) + (lambda () + (let ((repo (repository-open "guix.git"))) + (oid->string (object-id (revparse-single repo ref))))) + #:unwind? #t)) + +(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) + + (if (null? lines) + #f + (string->date (first lines) + "~Y-~m-~d ~H:~M:~S ~z"))) + (loop (read-line pipe) + (cons line lines)))))))) diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index 5f2f04c..a7e376d 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -16,45 +16,11 @@ #: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 git-repository) #: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" @@ -84,24 +50,6 @@ (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) - - (if (null? lines) - #f - (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 |