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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import git)
#:use-module (guix build utils)
#:use-module (guix diagnostics)
#:use-module (guix git)
#:use-module (guix git-download)
#:use-module (guix i18n)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-28)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:export (%generic-git-updater))
;;; Commentary:
;;;
;;; This module provides a generic package updater for packages hosted on Git
;;; repositories.
;;;
;;; It tries to be smart about tag names, but if it is not automatically able
;;; to parse the tag names correctly, users can set the `tag-prefix',
;;; `tag-suffix' and `tag-version-delimiter' properties of the package to make
;;; the updater parse the Git tag name correctly.
;;;
;;; Code:
;;; Errors & warnings
(define-condition-type &git-tag-error &error
git-tag-error?
(kind git-tag-error-kind))
(define (git-tag-error kind)
(raise (condition (&message (message (format "bad `~a' property")))
(&git-tag-error
(kind kind)))))
(define (git-tag-warning package c)
(warning (package-location package)
(G_ "~a for package `~a'~%")
(condition-message c)
(package-name package)))
(define-condition-type &git-no-tags-error &error
git-no-tags-error?)
(define (git-no-tags-error)
(raise (condition (&message (message "no tags were found"))
(&git-no-tags-error))))
(define (git-no-tags-warning package c)
(warning (package-location package)
(G_ "~a for package `~a'~%")
(condition-message c)
(package-name package)))
(define (git-fetch-warning package)
(warning (package-location package)
(G_ "failed to fetch Git repository for package `~a'~%")
(package-name package)))
\f
;;; Helper functions
(define (string-split* str delim)
"Like `string-split', but DELIM is a string instead of a
char-set."
(filter (lambda (str) (not (equal? str "")))
(string-split str (string->char-set delim))))
(define* (get-version package tag #:key prefix suffix delim)
(define delim* (if delim delim "."))
(define prefix-regexp "^[^0-9]*")
(define suffix-regexp (string-append "[^0-9" (regexp-quote delim*) "]*$"))
(define delim-regexp (string-append "^[0-9]+" (regexp-quote delim*) "[0-9]+"))
(define no-prefix
(let ((match (string-match (or prefix prefix-regexp) tag)))
(if match
(regexp-substitute #f match 'post)
(git-tag-error 'tag-prefix))))
(define no-suffix
(let ((match (string-match (or suffix suffix-regexp) no-prefix)))
(if match
(regexp-substitute #f match 'pre)
(git-tag-error 'tag-suffix))))
(define no-delims
(if (string-match delim-regexp no-suffix)
(string-split* no-suffix delim*)
(git-tag-error 'tag-version-delimiter)))
(string-join no-delims "."))
(define (sort-tags tags)
"Sort TAGS, a list if Git tags, such that the latest tag is the last element."
(sort tags (lambda (a b)
(eq? (version-compare a b) '<))))
\f
;;; Updater
(define (get-latest-tag url)
"Return the latest tag available from the Git repository at URL."
(let ((tags (map (cut string-drop <> (string-length "refs/tags/"))
(ls-remote-refs url #:tags? #t))))
(if (null? tags)
(git-no-tags-error)
(last (sort-tags tags)))))
(define (latest-git-tag-version package tag-prefix tag-suffix
tag-version-delimiter)
"Given a PACKAGE, the TAG-PREFIX, TAG-SUFFIX, and TAG-VERSION-DELIMITER
properties of PACKAGE, returns the latest version of PACKAGE."
(guard (c ((eq? (exception-kind c) 'git-error)
(git-fetch-warning package)
#f)
((git-tag-error? c)
(git-tag-warning package c)
#f)
((git-no-tags-error? c)
(git-no-tags-warning package c)
#f))
(let* ((source (package-source package))
(git-uri (origin-uri source))
(url (git-reference-url (origin-uri source)))
(latest-tag (get-latest-tag url)))
(get-version package
latest-tag
#:prefix tag-prefix
#:suffix tag-suffix
#:delim tag-version-delimiter))))
(define (git-package? package)
"Whether the origin of PACKAGE is a Git repostiory."
(match (package-source package)
((? origin? origin)
(and (eq? (origin-method origin) git-fetch)
(git-reference? (origin-uri origin))))
(_ #f)))
(define (latest-git-release package)
"Return the latest release of PACKAGE."
(let* ((name (package-name package))
(properties (package-properties package))
(tag-prefix (assq-ref properties 'tag-prefix))
(tag-suffix (assq-ref properties 'tag-suffix))
(tag-version-delimiter (assq-ref properties 'tag-version-delimiter))
(old-version (package-version package))
(url (git-reference-url (origin-uri (package-source package))))
(new-version (latest-git-tag-version package
tag-prefix
tag-suffix
tag-version-delimiter)))
(if new-version
(upstream-source
(package name)
(version new-version)
(urls (list url)))
;; No new release or no tags available.
#f)))
(define %generic-git-updater
(upstream-updater
(name 'generic-git)
(description "Updater for packages hosted on Git repositories")
(pred git-package?)
(latest latest-git-release)))
|