[bug#53144] [PATCH 12/13] import: Add 'latest-git' updater.

[Maxime Devos <maximedevos@telenet.be>]

* 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@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)))
+
 \f
 
 ;;;
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@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