Package: guix-patches;
Reported by: Maxime Devos <maximedevos <at> telenet.be>
Date: Sun, 9 Jan 2022 19:09:01 UTC
Severity: normal
Tags: moreinfo, patch
Fix blocked by 55399: libgit2 1.4.3 directory owner validation breaks Guix
View this message in rfc822 format
From: Maxime Devos <maximedevos <at> telenet.be> To: 53144 <at> debbugs.gnu.org Cc: Maxime Devos <maximedevos <at> telenet.be> Subject: [bug#53144] [PATCH 12/13] import: Add 'latest-git' updater. Date: Sun, 9 Jan 2022 19:10:14 +0000
* Makefile.am (MODULES, SCM_TESTS): Register new files.
* doc/guix.texi (Invoking guix refresh): Document it.
* guix/import/latest-git.scm: New importer file.
* guix/upstream.scm (increment-git-version): New procedure.
* tests/import-latest-git.scm: New test file.
---
Makefile.am | 2 +
doc/guix.texi | 17 +++
guix/import/latest-git.scm | 104 ++++++++++++++++++
guix/upstream.scm | 9 ++
tests/import-latest-git.scm | 204 ++++++++++++++++++++++++++++++++++++
5 files changed, 336 insertions(+)
create mode 100644 guix/import/latest-git.scm
create mode 100644 tests/import-latest-git.scm
diff --git a/Makefile.am b/Makefile.am
index d6aabac261..e380c7c83d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -267,6 +267,7 @@ MODULES = \
guix/import/json.scm \
guix/import/kde.scm \
guix/import/launchpad.scm \
+ guix/import/latest-git.scm \
guix/import/minetest.scm \
guix/import/opam.scm \
guix/import/print.scm \
@@ -482,6 +483,7 @@ SCM_TESTS = \
tests/hackage.scm \
tests/home-import.scm \
tests/import-git.scm \
+ tests/import-latest-git.scm \
tests/import-utils.scm \
tests/inferior.scm \
tests/lint.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 5c1b9adb87..58ccc75ccf 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12619,6 +12619,23 @@ property to @code{#t}.
(release-tag-version-delimiter . ":"))))
@end lisp
+@item latest-git
+@cindex latest-git
+@cindex with-latest-git-commit
+another updater for packages hosted on Git repositories. The difference
+with @code{generic-git} is that it always choses the latest commit, even
+when it does not have a version tag. As this practice should remain
+exceptional (@pxref{Version Numbers}), packages have to opt-in this
+updater, by using @code{git-version} to construct the version number and
+setting the @code{with-latest-git-commit} package property.
+
+Usually, it can be simply be set to @code{#true} to use the latest Git
+commit on the default branch---i.e., HEAD in Git parlance. If this is
+not desired, for example if upstream has a branch that is considered
+‘stable’, it can be set to the name of a reference to take commits from.
+For example, to take commits from a branch named @code{stable}, the
+property @code{with-latest-git-commit} needs to be set to
+@code{refs/heads/stable}.
@end table
diff --git a/guix/import/latest-git.scm b/guix/import/latest-git.scm
new file mode 100644
index 0000000000..208f112153
--- /dev/null
+++ b/guix/import/latest-git.scm
@@ -0,0 +1,104 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
+;;;
+;;; 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 latest-git)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix ui)
+ #:use-module (guix git)
+ #:use-module (guix git-download)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%latest-git-updater))
+
+(define (check-valid-with-latest-git-commit? package value)
+ "Verify that VALUE is a valid value for the 'with-latest-git-commit'
+package property of PACKAGE. If so, return #true. Otherwise, emit a
+warning and return #false. It is assumed VALUE is not false."
+ (or (string? value)
+ (eq? #true value)
+ (begin
+ (warning (or (package-field-location package 'properties)
+ (package-location package))
+ (G_ "Package ~a has an invalid 'with-latest-git-commit' \
+property.~%")
+ (package-name package))
+ #false)))
+
+(define (with-latest-git-commit? package)
+ "Return true if PACKAGE is hosted on a Git repository and it is requested
+that the latest Git commit is used even when not formally released."
+ (match (package-source package)
+ ((? origin? origin)
+ (and (decompose-git-version (package-version package))
+ (eq? (origin-method origin) git-fetch)
+ (git-reference? (origin-uri origin))
+ (and=> (assq-ref (package-properties package)
+ 'with-latest-git-commit)
+ (cut check-valid-with-latest-git-commit? package <>))))
+ (_ #f)))
+
+(define (latest-commit-reference-name package)
+ "Return the name of the reference that is expected to hold the latest Git
+commit to use as source code."
+ (match (assq-ref (package-properties package) 'with-latest-git-commit)
+ ('#true "HEAD")
+ ((? string? reference) reference)))
+
+(define (latest-git-upstream package)
+ "Return an <upstream-source> for the latest git commit of PACKAGE.
+If the reference pointing to the latest git commit has been deleted,
+return #false instead."
+ (let* ((name (package-name package))
+ (old-version (package-version package))
+ (old-reference (origin-uri (package-source package)))
+ (reference-name (latest-commit-reference-name package))
+ (commit (lookup-reference (git-reference-url old-reference)
+ reference-name)))
+ (if commit
+ (upstream-source
+ (package name)
+ (version
+ ;; See 'oid->commit' in (guix git) for why not string=?.
+ ;; Don't increment the revision if the commit remains the same.
+ (if (string-prefix? commit (git-reference-commit old-reference))
+ old-version
+ (increment-git-version old-version commit)))
+ (urls (git-reference
+ (inherit old-reference)
+ (commit commit))))
+ (begin
+ (warning (package-location package)
+ (G_ "Cannot update ~a because the reference ~a of ~a has \
+disappeared.~%")
+ (package-name package)
+ reference-name
+ (let ((maybe-hyperlink
+ (if (supports-hyperlinks? (guix-warning-port))
+ hyperlink
+ (lambda (x y) x)))
+ (url (git-reference-url old-reference)))
+ (maybe-hyperlink url url)))
+ #false))))
+
+(define %latest-git-updater
+ (upstream-updater
+ (name 'latest-git)
+ (description "Updater for packages using latest Git commit")
+ (pred with-latest-git-commit?)
+ (latest latest-git-upstream)))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 6b65147356..a9211fe45b 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -64,6 +64,7 @@ (define-module (guix upstream)
decompose-git-version
maybe-git-version->revision
maybe-git-versions->revision-replacements ; for tests
+ increment-git-version
upstream-updater
upstream-updater?
@@ -281,6 +282,14 @@ (define (maybe-git-versions->revision-replacements old new)
. ,(object->string `(revision ,new-revision))))
'())))
+(define (increment-git-version old-git-version commit)
+ "Increment the revision in OLD-GIT-VERSION by one, replacing the commit
+by COMMIT. It is assumed OLD-GIT-VERSION is a result of 'git-version'."
+ (let-values (((old-base-version revision old-commit)
+ (decompose-git-version old-git-version)))
+ (git-version old-base-version
+ (number->string (+ 1 (string->number revision))) commit)))
+
;;;
diff --git a/tests/import-latest-git.scm b/tests/import-latest-git.scm
new file mode 100644
index 0000000000..d0dc149ff8
--- /dev/null
+++ b/tests/import-latest-git.scm
@@ -0,0 +1,204 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
+;;;
+;;; 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-latest-git)
+ #:use-module (git)
+ #:use-module (guix git)
+ #:use-module (guix tests)
+ #:use-module (guix packages)
+ #:use-module (guix import latest-git)
+ #:use-module (guix upstream)
+ #:use-module (guix git-download)
+ #:use-module (guix hg-download)
+ #:use-module (guix tests git)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-64))
+
+(test-begin "git")
+
+(define latest-git-upstream
+ (upstream-updater-latest %latest-git-updater))
+
+(define with-latest-git-commit?
+ (upstream-updater-predicate %latest-git-updater))
+
+(define* (make-package directory base-version revision commit
+ #:optional (properties
+ '((with-latest-git-commit . #true))))
+ (dummy-package "test-package"
+ (version (git-version base-version revision commit))
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url (string-append "file://" directory))
+ (commit commit)))
+ (sha256 #f)))
+ (properties properties)))
+
+(define (find-commit-as-string repository query)
+ (oid->string (commit-id (find-commit repository query))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git: an update"
+ '(#true #true #true)
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (add "b.txt" "B")
+ (commit "Second commit"))
+ (with-repository directory repository
+ (let* ((old-commit
+ (find-commit-as-string repository "First commit"))
+ (new-commit
+ (find-commit-as-string repository "Second commit"))
+ (package (make-package directory "1.0" "0" old-commit))
+ (update (latest-git-upstream package)))
+ (list (with-latest-git-commit? package)
+ (string=? (upstream-source-version update)
+ (git-version "1.0" "1" new-commit))
+ ;; See 'oid->commit in (guix git) for why not string=?.
+ (string-prefix?
+ (git-reference-commit (upstream-source-urls update))
+ new-commit))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git: no new commit, no new revision"
+ '(#true #true #true)
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit"))
+ (with-repository directory repository
+ (let* ((commit
+ (find-commit-as-string repository "First commit"))
+ (package (make-package directory "1.0" "0" commit))
+ (update (latest-git-upstream package)))
+ ;; 'update' being #false would work as well.
+ (list (with-latest-git-commit? package)
+ (string=? (upstream-source-version update)
+ (package-version package))
+ (string-prefix?
+ (git-reference-commit (upstream-source-urls update))
+ commit))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git: non-HEAD commits ignored"
+ '(#true #true #true)
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "let-me-be-head")
+ (branch "dev")
+ (checkout "dev")
+ (add "b.txt" "B")
+ (commit "Not ready for distribution!")
+ (checkout "let-me-be-head"))
+ (with-repository directory repository
+ (let* ((commit
+ (find-commit-as-string repository "First commit"))
+ (package (make-package directory "1.0" "0" commit))
+ (update (latest-git-upstream package)))
+ (list (with-latest-git-commit? package)
+ (string=? (upstream-source-version update)
+ (package-version package))
+ (string-prefix?
+ (git-reference-commit (upstream-source-urls update))
+ commit))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git: non-HEAD branches can be chosen"
+ '(#true #true #true)
+ (with-temporary-git-repository directory
+ '((checkout "stable-for-distros" orphan)
+ (add "a.txt" "A")
+ (commit "First commit")
+ (add "b.txt" "B")
+ (commit "Here's a bugfix.")
+ (branch "unstable")
+ (checkout "unstable")
+ (add "c.txt" "C")
+ ;; This commit may not be chosen.
+ (commit "New feature, needs more work before distributing."))
+ (with-repository directory repository
+ (let* ((old-commit
+ (find-commit-as-string repository "First commit"))
+ (new-commit
+ (find-commit-as-string repository "Here's a bugfix"))
+ (properties
+ '((with-latest-git-commit . "refs/heads/stable-for-distros")))
+ (package (make-package directory "1.0" "0" old-commit properties))
+ (update (latest-git-upstream package)))
+ (list (with-latest-git-commit? package)
+ (string=? (upstream-source-version update)
+ (git-version "1.0" "1" new-commit))
+ (string-prefix?
+ (git-reference-commit (upstream-source-urls update))
+ new-commit))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git: deleted references handled gracefully"
+ #false
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit"))
+ (with-repository directory repository
+ (let* ((properties
+ '((with-latest-git-commit . "refs/heads/I-do-not-exist")))
+ (package (make-package directory "1.0" "0" "cabba9e" properties)))
+ (latest-git-upstream package)))))
+
+(test-equal "with-latest-git-commit?"
+ '(#true #false #true #true #false #false)
+ (map (lambda (properties)
+ (with-latest-git-commit?
+ (make-package "/dev/null" "1.0" "0" "cabba9e" properties)))
+ (list '((with-latest-git-commit . #true)) ; defaults to HEAD
+ '() ; packages have to opt-in, so #false
+ '((with-latest-git-commit . "HEAD")) ; explicit HEAD is ok
+ '((with-latest-git-commit . "refs/heads/main")) ; another branch
+ '((with-latest-git-commit . #xf00ba3)) ; bogus
+ '((irrelevant . #true)))))
+
+(test-equal "with-latest-git-commit?: not for other VCS"
+ #false
+ (with-latest-git-commit?
+ (package
+ (inherit (make-package "/dev/null" "1.0.0" "0" "cabba9e"))
+ (source
+ (origin
+ (method hg-fetch)
+ (uri (hg-reference
+ (url "https://foo")
+ (changeset "foo")))
+ (sha256 #false))))))
+
+(test-equal "with-latest-git-commit?: only if there's source code"
+ #false
+ (with-latest-git-commit?
+ (package
+ (inherit (make-package "/dev/null" "1.0.0" "0" "cabba9e"))
+ (source #false))))
+
+(test-equal "with-latest-git-commit?: only for git-version"
+ #false
+ (with-latest-git-commit?
+ (package
+ (inherit (make-package "/dev/null" "1.0.0" "0" "cabba9e"))
+ (version "1.0.0"))))
+
+(test-end "git")
--
2.34.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.