@@ -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 \
@@ -11920,6 +11920,33 @@ 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{tag-prefix}: a regular expression for matching a prefix of
+the tag name.
+
+@item @code{tag-suffix}: a regular expression for matching a suffix of
+the tag name.
+
+@item @code{tag-version-delimiter}: a string used as the delimiter in
+the tag name for separating the numbers of the version.
+@end itemize
+
+@lisp
+(package
+ (name "foo")
+ ;; ...
+ (properties
+ '((tag-prefix . "^release0-")
+ (tag-suffix . "[a-z]?$")
+ (tag-version-delimiter . ":"))))
+@end lisp
+
@end table
For instance, the following command only checks for updates of Emacs
new file mode 100644
@@ -0,0 +1,223 @@
+;;; 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 (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)))
+
+
+;;; 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) '<))))
+
+
+;;; Updater
+
+(define (get-remote url git-uri)
+ "Given a URL and GIT-URI, a <git-reference> record, return the ``origin'' remote."
+ (let* ((checkout (update-cached-checkout url
+ #:recursive?
+ (git-reference-recursive? git-uri)))
+ (repository (repository-open checkout)))
+ (remote-lookup repository "origin")))
+
+(define (get-latest-tag remote)
+ "Given a Git REMOTE, return that latest tag available."
+ (remote-connect remote)
+
+ (define tags
+ (sort-tags
+ (map (lambda (tag)
+ (string-drop tag (string-length "refs/tags/")))
+ (filter (lambda (ref)
+ ;; Every tag has two refs:
+ ;;
+ ;; * refs/tags/1.2.3^{}
+ ;; * refs/tags/1.2.3
+ ;;
+ ;; remove the one with the trailing ^{}
+ (and (not (string-suffix? "^{}" ref))
+ (string-prefix? "refs/tags/" ref)))
+ (map (lambda (remote-head)
+ (remote-head-name remote-head))
+ (remote-ls remote))))))
+
+ (remote-disconnect remote)
+
+ (if (null? tags)
+ (git-no-tags-error)
+ (last 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)))
+ (remote (get-remote url git-uri))
+ (latest-tag (get-latest-tag remote)))
+ (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)))