summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorXinglu Chen <public@yoctocell.xyz>2021-08-16 14:15:49 +0200
committerXinglu Chen <public@yoctocell.xyz>2021-08-16 14:34:34 +0200
commit0356c7603a4611d40875b4eb352e3378295f34bc (patch)
tree7318e58244afcaf154328f70e01802d192743d92
parentc0e6e8d25e3750a35bebc80469ee86e7826bd769 (diff)
WIP: Add 'generic-git' updater.
* guix/import/git.scm: New file. * Makefile.am (MODULES): Add it. * doc/guix.texi (Invoking guix refresh): Document it.
-rw-r--r--Makefile.am1
-rw-r--r--doc/guix.texi19
-rw-r--r--guix/import/git.scm193
3 files changed, 213 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index 5542aa1c56..5c014d10b8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -252,6 +252,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 \
diff --git a/doc/guix.texi b/doc/guix.texi
index 6ba52623c0..8dc1792e2c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11854,6 +11854,25 @@ 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. To make it
+work properly, packages should define three
+properties---@code{tag-prefix}, @code{tag-suffix}, and
+@code{tag-version-delimiter}.
+
+@itemize
+@item @code{tag-prefix} should be a string that
+corresponds to the prefix of the tag name; it is set to @code{""} by
+default.
+
+@item @code{tag-suffix} should be a string that corresponds to the
+suffix of the tag name; it is set to @code{""} by default.
+
+@item @code{tag-version-delimiter} is the delimiter used in the tag name for
+separating the numbers of the version; it is set to @code{"."} by
+default.
+@end itemize
+
@end table
For instance, the following command only checks for updates of Emacs
diff --git a/guix/import/git.scm b/guix/import/git.scm
new file mode 100644
index 0000000000..ddb50cc9fa
--- /dev/null
+++ b/guix/import/git.scm
@@ -0,0 +1,193 @@
+;;; 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 (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (guix upstream)
+ #:use-module (guix git-download)
+ #:use-module (guix utils)
+ #:use-module (guix build utils)
+ #:use-module (guix git)
+ #:use-module (guix records)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (guix packages)
+ #:export (%generic-git-updater))
+
+;;; Commentary:
+;;;
+;;; This module provides a generic package updater for packages hosted on Git
+;;; repositories.
+;;;
+;;; It uses the 'tag-prefix', 'tag-suffix' and 'tag-version-delimiter'
+;;; properties of the package to parse the Git tag name correctly. They
+;;; default to "", "", and ".", respectively.
+;;;
+;;; 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 ""))
+ (&git-tag-error
+ (kind kind)))))
+
+(define (git-tag-warning package c)
+ (warning (package-location package)
+ (G_ "bad '~a' property for package ~a~%")
+ (git-tag-error-kind c)
+ (package-name package)))
+
+
+;;; Helper functions
+
+(define (read-lines port)
+ "Read the lines from PORT, and return a list where each element
+corresponding to each line. Note that the order of the lines will be
+reversed."
+ (let loop ((lines '()))
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) lines)
+ (else (loop (cons line lines)))))))
+
+(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 (is-substring? str1 str2)
+ "Whether the STR1 is a substring of STR2."
+ (string-any (string->char-set str1) str2))
+
+(define (safe-first lst)
+ "Same as 'first', but return #f if LST is empty."
+ (if (null? lst)
+ #f
+ (first lst)))
+
+(define* (get-version package tag #:key prefix suffix delim)
+ "Return the version of PACKAGE corresponding to the Git TAG name. PREFIX is
+the 'tag-prefix' property of PACKAGE, SUFFIX is the 'tag-suffix' property of
+PACKAGE, and DELIM is the 'tag-version-delimiter' property of PACKAGE."
+ (guard (c ((git-tag-error? c)
+ (begin
+ (git-tag-warning package c)
+ #f)))
+ (let* ((no-prefix (if (string-prefix? prefix tag)
+ (string-drop tag (string-length prefix))
+ (git-tag-error 'tag-prefix)))
+ (no-suffix (if (string-suffix? suffix no-prefix)
+ (string-drop-right no-prefix (string-length suffix))
+ (git-tag-error 'tag-suffix)))
+ ;; XXX: Not the most robust test
+ (no-delims (if (and (is-substring? delim no-suffix)
+ (not (string-prefix? delim no-suffix))
+ (not (string-suffix? delim no-suffix)))
+ (string-split* no-suffix delim)
+ (git-tag-error 'tag-version-delimiter))))
+ (string-join no-delims "."))))
+
+
+;;; Updater
+
+(define (latest-git-tag-version package tag-prefix tag-suffix
+ tag-version-delimiter)
+ "Return the latest version, and the name of the Git tag of PACKAGE. This
+relies on the Git tag having the version of the package in the name. It will
+also read the 'tag-prefix', 'tag-suffix', and 'tag-version-delimiter'
+properties of PACKAGE."
+ (let* ((origin (origin-uri (package-source package)))
+ (url (git-reference-url origin))
+ (version (package-version package))
+
+ (checkout (update-cached-checkout
+ url #:recursive? (git-reference-recursive? origin)))
+ (port (with-directory-excursion checkout
+ ;; TODO: Use Guile-Git instead. Currently, there is no way
+ ;; to list tags in a repo.
+ (open-pipe* OPEN_READ
+ "git"
+ "tag"
+ "--sort=version:refname")))
+ (latest-tag (safe-first (read-lines port))))
+ (if latest-tag
+ (let ((latest-version (get-version package
+ latest-tag
+ #:prefix tag-prefix
+ #:suffix tag-suffix
+ #:delim tag-version-delimiter)))
+ (values latest-version latest-tag))
+ ;; No tags were found.
+ (values #f #f))))
+
+
+(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 (or (assq-ref properties 'tag-prefix) ""))
+ (tag-suffix (or (assq-ref properties 'tag-suffix) ""))
+ (tag-version-delimiter (or (assq-ref properties 'tag-version-delimiter)
+ "."))
+ (old-version (package-version package))
+ (url (git-reference-url (origin-uri (package-source package)))))
+ (let ((new-version new-tag
+ (latest-git-tag-version package
+ tag-prefix
+ tag-suffix
+ tag-version-delimiter)))
+
+ (if new-version
+ (upstream-source
+ (package name)
+ (version new-version)
+ (urls (list (git-reference
+ (url url)
+ (commit new-tag)))))
+ ;; 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)))