blob: 2aab8fd79370a29cce991c80157c63b706645d71 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(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 (%git-repository-location
ensure-repository-exists!
update-repository!
with-bare-git-repository
with-git-worktree
get-commit
get-git-branch-head-committer-date))
(define %git-repository-location
(make-parameter #f))
(define* (guix.git-excursion thunk #:optional dir)
(monitor
(with-directory-excursion (or dir (%git-repository-location))
(thunk))))
(define (ensure-repository-exists!)
(monitor
(unless (file-exists? (%git-repository-location))
(invoke "git" "clone"
"--bare"
"https://git.savannah.gnu.org/git/guix.git"
(%git-repository-location))
(guix.git-excursion
(lambda ()
(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!)
(guix.git-excursion 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)))
(guix.git-excursion thunk name)
(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 (%git-repository-location))))
(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))))))))
|