me
/
guix
Archived
1
0
Fork 0
Code

import: Add 'generic-git' updater. 

* guix/git.scm (ls-remote-refs): New procedure.
* tests/git.scm ("remote-refs" "remote-refs: only tags"): New tests.
* guix/import/git.scm: New file.
* doc/guix.texi (Invoking guix refresh): Document it.
* tests/import-git.scm: New test file.
* Makefile.am (MODULES, SCM_TESTS): Register the new files.

Co-authored-by: Sarah Morgensen <iskarian@mgsn.dev>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
master
Xinglu Chen 2021-09-17 10:04:49 +02:00 committed by Ludovic Courtès
parent 6597f80839
commit 59ee10754e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
6 changed files with 575 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -254,6 +254,7 @@ MODULES = \
guix/import/egg.scm \
guix/import/elpa.scm \
guix/import/gem.scm \
guix/import/git.scm \
guix/import/github.scm \
guix/import/gnome.scm \
guix/import/gnu.scm \
@ -473,6 +474,7 @@ SCM_TESTS = \
tests/graph.scm \
tests/gremlin.scm \
tests/hackage.scm \
tests/import-git.scm \
tests/import-utils.scm \
tests/inferior.scm \
tests/lint.scm \

34
doc/guix.texi
View File

@ -11928,6 +11928,40 @@ the updater for @uref{https://launchpad.net, Launchpad} packages.
@item generic-html
a generic updater that crawls the HTML page where the source tarball of
the package is hosted, when applicable.
@item generic-git
a generic updater for packages hosted on Git repositories. It tries to
be smart about parsing Git tag names, but if it is not able to parse the
tag name and compare tags correctly, users can define the following
properties for a package.
@itemize
@item @code{release-tag-prefix}: a regular expression for matching a prefix of
the tag name.
@item @code{release-tag-suffix}: a regular expression for matching a suffix of
the tag name.
@item @code{release-tag-version-delimiter}: a string used as the delimiter in
the tag name for separating the numbers of the version.
@item @code{accept-pre-releases}: by default, the updater will ignore
pre-releases; to make it also look for pre-releases, set the this
property to @code{#t}.
@end itemize
@lisp
(package
(name "foo")
;; ...
(properties
'((release-tag-prefix . "^release0-")
(release-tag-suffix . "[a-z]?$")
(release-tag-version-delimiter . ":"))))
@end lisp
@end table
For instance, the following command only checks for updates of Emacs

41
guix/git.scm
View File

@ -57,6 +57,8 @@
commit-difference
commit-relation
remote-refs
git-checkout
git-checkout?
git-checkout-url
@ -571,6 +573,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
(if (set-contains? oldest new)
'descendant
'unrelated))))))
;;
;;; Remote operations.
;;;
(define* (remote-refs url #:key tags?)
"Return the list of references advertised at Git repository URL. If TAGS?
is true, limit to only refs/tags."
(define (ref? ref)
;; Like `git ls-remote --refs', only show actual references.
(and (string-prefix? "refs/" ref)
(not (string-suffix? "^{}" ref))))
(define (tag? ref)
(string-prefix? "refs/tags/" ref))
(define (include? ref)
(and (ref? ref)
(or (not tags?) (tag? ref))))
(define (remote-head->ref remote)
(let ((name (remote-head-name remote)))
(and (include? name)
name)))
(with-libgit2
(call-with-temporary-directory
(lambda (cache-directory)
(let* ((repository (repository-init cache-directory))
;; Create an in-memory remote so we don't touch disk.
(remote (remote-create-anonymous repository url)))
(remote-connect remote)
(let* ((remote-heads (remote-ls remote))
(refs (filter-map remote-head->ref remote-heads)))
;; Wait until we're finished with the repository before closing it.
(remote-disconnect remote)
(repository-close! repository)
refs))))))
;;;

225
guix/import/git.scm 100644
View File

@ -0,0 +1,225 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; 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 format)
#: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-34)
#:use-module (srfi srfi-35)
#:export (%generic-git-updater
;; For tests.
latest-git-tag-version))
;;; 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 `release-tag-prefix',
;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the
;;; package to make the updater parse the Git tag name correctly.
;;;
;;; Possible improvements:
;;;
;;; * More robust method for trying to guess the delimiter. Maybe look at the
;;; previous version/tag combo to determine the delimiter.
;;;
;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g.,
;;; 2021.12.31. Honor a `release-tag-date-scheme?' property?
;;;
;;; Code:
;;; Errors & warnings
(define-condition-type &git-no-valid-tags-error &error
git-no-valid-tags-error?)
(define (git-no-valid-tags-error)
(raise (condition (&message (message "no valid tags found"))
(&git-no-valid-tags-error))))
(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))))
;;; Updater
(define %pre-release-words
'("alpha" "beta" "rc" "dev" "test" "pre"))
(define %pre-release-rx
(map (lambda (word)
(make-regexp (string-append ".+" word) regexp/icase))
%pre-release-words))
(define* (version-mapping tags #:key prefix suffix delim pre-releases?)
"Given a list of Git TAGS, return an association list where the car is the
version corresponding to the tag, and the cdr is the name of the tag."
(define (guess-delimiter)
(let ((total (length tags))
(dots (reduce + 0 (map (cut string-count <> #\.) tags)))
(dashes (reduce + 0 (map (cut string-count <> #\-) tags)))
(underscores (reduce + 0 (map (cut string-count <> #\_) tags))))
(cond
((>= dots (* total 0.35)) ".")
((>= dashes (* total 0.8)) "-")
((>= underscores (* total 0.8)) "_")
(else ""))))
(define delim-rx (regexp-quote (or delim (guess-delimiter))))
(define suffix-rx (string-append (or suffix "") "$"))
(define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*")))
(define pre-release-rx
(if pre-releases?
(string-append "(.*(" (string-join %pre-release-words "|") ").*)")
""))
(define tag-rx
(string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*"
"(" delim-rx "[^[:punct:]" delim-rx "]+)"
;; If there are no delimiters, it could mean that the
;; version just contains one number (e.g., "2"), thus, use
;; "*" instead of "+" to match zero or more numbers.
(if (string=? delim-rx "") "*" "+") ")"
;; We don't want the pre-release stuff (e.g., "-alpha") be
;; part of the first group; otherwise, the "-" in "-alpha"
;; might be interpreted as a delimiter, and thus replaced
;; with "."
pre-release-rx suffix-rx))
(define (get-version tag)
(let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
(and=> (and tag-match
(regexp-substitute/global
#f delim-rx (match:substring tag-match 1)
;; If there were no delimiters, don't insert ".".
'pre (if (string=? delim-rx "") "" ".") 'post))
(lambda (version)
(if pre-releases?
(string-append version (match:substring tag-match 3))
version)))))
(define (entry<? a b)
(eq? (version-compare (car a) (car b)) '<))
(stable-sort (filter-map (lambda (tag)
(let ((version (get-version tag)))
(and version (cons version tag))))
tags)
entry<?))
(define* (latest-tag url #:key prefix suffix delim pre-releases?)
"Return the latest version and corresponding tag available from the Git
repository at URL."
(define (pre-release? tag)
(any (cut regexp-exec <> tag)
%pre-release-rx))
(let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
(remote-refs url #:tags? #t)))
(versions->tags
(version-mapping (if pre-releases?
tags
(filter (negate pre-release?) tags))
#:prefix prefix
#:suffix suffix
#:delim delim
#:pre-releases? pre-releases?)))
(cond
((null? tags)
(git-no-tags-error))
((null? versions->tags)
(git-no-valid-tags-error))
(else
(match (last versions->tags)
((version . tag)
(values version tag)))))))
(define (latest-git-tag-version package)
"Given a PACKAGE, return the latest version of it, or #f if the latest version
could not be determined."
(guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "~a for ~a~%")
(condition-message c)
(package-name package))
#f)
((eq? (exception-kind c) 'git-error)
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "failed to fetch Git repository for ~a~%")
(package-name package))
#f))
(let* ((source (package-source package))
(url (git-reference-url (origin-uri source)))
(property (cute assq-ref (package-properties package) <>)))
(latest-tag url
#:prefix (property 'release-tag-prefix)
#:suffix (property 'release-tag-suffix)
#:delim (property 'release-tag-version-delimiter)
#:pre-releases? (property 'accept-pre-releases?)))))
(define (git-package? package)
"Return true if PACKAGE is hosted on a Git repository."
(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 an <upstream-source> for the latest release of PACKAGE."
(let* ((name (package-name package))
(old-version (package-version package))
(url (git-reference-url (origin-uri (package-source package))))
(new-version (latest-git-tag-version package)))
(and new-version
(upstream-source
(package name)
(version new-version)
(urls (list url))))))
(define %generic-git-updater
(upstream-updater
(name 'generic-git)
(description "Updater for packages hosted on Git repositories")
(pred git-package?)
(latest latest-git-release)))

28
tests/git.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
;;;
;;; This file is part of GNU Guix.
;;;
@ -161,4 +162,31 @@
(commit-relation master1 merge)
(commit-relation merge master1))))))
(unless (which (git-command)) (test-skip 1))
(test-equal "remote-refs"
'("refs/heads/develop" "refs/heads/master"
"refs/tags/v1.0" "refs/tags/v1.1")
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "v1.0" "release-1.0")
(branch "develop")
(checkout "develop")
(add "b.txt" "B")
(commit "Second commit")
(tag "v1.1" "release-1.1"))
(remote-refs directory)))
(unless (which (git-command)) (test-skip 1))
(test-equal "remote-refs: only tags"
'("refs/tags/v1.0" "refs/tags/v1.1")
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "v1.0" "Release 1.0")
(add "b.txt" "B")
(commit "Second commit")
(tag "v1.1" "Release 1.1"))
(remote-refs directory #:tags? #t)))
(test-end "git")

245
tests/import-git.scm 100644
View File

@ -0,0 +1,245 @@
;;; 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 (test-import-git)
#:use-module (git)
#:use-module (guix git)
#:use-module (guix tests)
#:use-module (guix packages)
#:use-module (guix import git)
#:use-module (guix git-download)
#:use-module (guix tests git)
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
;; Test the (guix import git) tools.
(test-begin "git")
(define* (make-package directory version #:optional (properties '()))
(dummy-package "test-package"
(version version)
(properties properties)
(source
(origin
(method git-fetch)
(uri (git-reference
(url (string-append "file://" directory))
(commit version)))
(sha256
(base32
"0000000000000000000000000000000000000000000000000000"))))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter"
"1.0.1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "1.0.1" "Release 1.0.1"))
(let ((package (make-package directory "1.0.0")))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter"
"1.0.1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "prefix-1.0.1" "Release 1.0.1"))
(let ((package (make-package directory "1.0.0"
'((release-tag-prefix . "prefix-")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter"
"1.0.1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "1.0.1-suffix-123" "Release 1.0.1"))
(let ((package (make-package directory "1.0.0"
'((release-tag-suffix . "-suffix-[0-9]*")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix"
"2021.09.07"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "2021-09-07" "Release 2021-09-07"))
(let ((package (make-package directory "2021-09-06"
'((release-tag-version-delimiter . "-")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix"
"20210907"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "20210907" "Release 20210907"))
(let ((package (make-package directory "20210906"
'((release-tag-version-delimiter . "")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter"
"2.0.0"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "Release-2.0.0suffix-1" "Release 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((release-tag-prefix . "Release-")
(release-tag-suffix . "suffix-[0-9]")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter"
"2.0.0"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "Release-2_0_0suffix-1" "Release 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((release-tag-prefix . "Release-")
(release-tag-suffix . "suffix-[0-9]")
(release-tag-version-delimiter . "_")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: only pre-releases available"
#f
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "2.0.0-rc1" "Release candidate for 2.0.0"))
(let ((package (make-package directory "1.0.0")))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases"
"2.0.0-rc1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "2.0.0-rc1" "Release candidate for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, and custom prefix"
"2.0.0-rc1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "version-2.0.0-rc1" "Release candidate for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-prefix . "version-")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix"
"2.0.0-rc1"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "2.0.0-rc1-suffix" "Release candidate for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-suffix . "-suffix")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part"
"2.0.0_alpha"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "2_0_0_alpha" "Alpha release for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-version-delimiter . "_")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix"
"2.0.0-alpha"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "prefix123-2.0.0-alpha-suffix" "Alpha release for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-prefix . "prefix[0-9]{3}-")
(release-tag-suffix . "-suffix")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter"
"2.0.0-alpha"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "prefix123-2-0-0-alpha-suffix" "Alpha release for 2.0.0"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-prefix . "prefix[0-9]{3}-")
(release-tag-suffix . "-suffix")
(release-tag-version-delimiter . "-")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix"
"2alpha"
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "prefix123-2alpha-suffix" "Alpha release for version 2"))
(let ((package (make-package directory "1.0.0"
'((accept-pre-releases? . #t)
(release-tag-prefix . "prefix[0-9]{3}-")
(release-tag-suffix . "-suffix")
(release-tag-version-delimiter . "")))))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: no tags found"
#f
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit"))
(let ((package (make-package directory "1.0.0")))
(latest-git-tag-version package))))
(unless (which (git-command)) (test-skip 1))
(test-equal "latest-git-tag-version: no valid tags found"
#f
(with-temporary-git-repository directory
'((add "a.txt" "A")
(commit "First commit")
(tag "Test" "Test tag"))
(let ((package (make-package directory "1.0.0")))
(latest-git-tag-version package))))
(test-end "git")