[bug#50072] [PATCH WIP 4/4] upstream: Support updating git-fetch origins.

[Maxime Devos]

Sarah Morgensen schreef op zo 15-08-2021 om 16:25 [-0700]:
> * guix/git-download.scm (checkout-to-store): New procedure.
> * guix/upstream.scm (guess-version-transform)
> (package-update/git-fetch): New procedures.
> (%method-updates): Add GIT-FETCH mapping.

Does it support packages defined like (a)

(define-public gnash
  (let ((commit "583ccbc1275c7701dc4843ec12142ff86bb305b4")
        (revision "0"))
    (package
      (name "gnash")
      (version (git-version "0.8.11" revision commit))
      (source (git-reference
                (url "https://example.org";)
                (commit commit)))
      [...])))

and (b)

(define-public gnash
  (package
    (name "gnash")
    (version "0.8.11")
    (source (git-reference
              (url "https://example.org";)
              (commit commit))
    [...]))
?

(Maybe (a) and (b) can be used as test cases.)

FWIW, I had a try at supporting git-fetch origins in "--with-latest" and
"guix refresh -e" myself, and had to modify 'package-update' to replace
commit strings.  IIRC, it supports (b), but not (a).  The patch is
attached, hopefully it will be useful.

Greetings,
Maxime.

diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index 4264341d6a..2904c3f94a 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -297,7 +297,7 @@ results.  The return value is a list of <package/keys> 
records."
 (define (make-minetest-sexp author/name version repository commit
                             inputs home-page synopsis
                             description media-license license)
-  "Return a S-expression for the minetest package with the given author/NAME,
+  "Return a S-expression for the minetest package with the given AUTHOR/NAME,
 VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
 MEDIA-LICENSE and LICENSE."
   `(package
@@ -452,3 +452,37 @@ list of AUTHOR/NAME strings."
                     #:repo->guix-package minetest->guix-package*
                     #:guix-name
                     (compose contentdb->package-name author/name->name)))
+
+#|
+(define (minetest-package? pkg)
+  (and (string-prefix? "minetest-" (package:package-name pkg))
+       (assq-ref (package:package-properties pkg) 'upstream-name)))
+
+(define (latest-minetest-release pkg)
+  "Return an <upstream-source> for the latest release of the package PKG."
+  (define upstream-name
+    (assoc-ref (package:package-properties pkg) 'upstream-name))
+  (define contentdb-package (contentdb-fetch upstream-name))
+  (define release (latest-release upstream-name))
+  (and contentdb-package release
+       (and-let* ((old-origin (package:package-source pkg))
+                  (old-reference (package:origin-uri old-origin))
+                  (is-git? (download:git-reference? old-reference))
+                  (commit (release-commit release)))
+         (upstream-source
+          (package (package:package-name pkg))
+          (version (release-title release))
+          (urls (download:git-reference
+                 (url (package-repository contentdb-package))
+                 (commit commit)))))))
+
+(define %minetest-updater
+  (upstream-updater
+   (name 'minetest)
+   (description "Updater for Minetest packages on ContentDB")
+   (pred minetest-package?)
+   (latest latest-minetest-release)))
+|#
+;;  #:use-module (guix upstream)
+;;  #:use-module ((guix git-download) #:prefix download:)
+;;  #:use-module ((guix packages) #:prefix package:)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index fb6c52a567..4f3bbbcb94 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -28,8 +28,10 @@
   #:use-module (guix ui)
   #:use-module (gcrypt hash)
   #:use-module (guix scripts)
+  #:use-module (guix serialization)
   #:use-module ((guix scripts build) #:select (%standard-build-options))
   #:use-module (guix store)
+  #:use-module (guix build utils)
   #:use-module (guix utils)
   #:use-module (guix packages)
   #:use-module (guix profiles)
@@ -307,6 +309,17 @@ update would trigger a complete rebuild."
            (G_ "no updater for ~a~%")
            (package-name package)))
 
+
+;; XXX adapted from (guix scripts hash)
+(define (file-hash file select? recursive?)
+  ;; Compute the hash of FILE.
+  (if recursive?
+      (let-values (((port get-hash) (open-sha256-port)))
+        (write-file file port #:select? select?)
+        (force-output port)
+        (get-hash))
+      (call-with-input-file file port-sha256)))
+
 (define* (update-package store package updaters
                          #:key (key-download 'interactive) warn?)
   "Update the source file that defines PACKAGE with the new version.
@@ -347,8 +360,8 @@ warn about packages that have no matching updater."
                            (package-name package)
                            (upstream-input-change-name change)))
                  (upstream-source-input-changes source))
-                (let ((hash (call-with-input-file tarball
-                              port-sha256)))
+                (let ((hash (file-hash tarball (const #t)
+                                       (directory-exists? tarball))))
                   (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
 downloaded and authenticated; not updating~%")
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 632e9ebc4f..61f67b57c1 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -24,6 +24,11 @@
   #:use-module (guix discovery)
   #:use-module ((guix download)
                 #:select (download-to-store url-fetch))
+  #:use-module ((guix git-download)
+                #:select (git-fetch git-reference?
+                                    git-reference-url
+                                    git-reference-commit
+                                    git-reference-recursive?))
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix diagnostics)
@@ -33,6 +38,7 @@
   #:use-module (guix store)
   #:use-module ((guix derivations) #:select (built-derivations 
derivation->output-path))
   #:autoload   (gcrypt hash) (port-sha256)
+  #:autoload   (guix git) (latest-repository-commit)
   #:use-module (guix monads)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -93,7 +99,8 @@
   upstream-source?
   (package        upstream-source-package)        ;string
   (version        upstream-source-version)        ;string
-  (urls           upstream-source-urls)           ;list of strings
+  ; list of strings or a <git-reference>
+  (urls           upstream-source-urls)
   (signature-urls upstream-source-signature-urls  ;#f | list of strings
                   (default #f))
   (input-changes  upstream-source-input-changes
@@ -361,6 +368,11 @@ values: 'interactive' (default), 'always', and 'never'."
                                                 system target)
   "Download SOURCE from its first URL and lower it as a fixed-output
 derivation that would fetch it."
+  (define url
+    (match (upstream-source-urls source)
+      ((first . _) first)
+      (_ (raise (formatted-message
+                 (G_ "git origins are unsupported by --with-latest"))))))
   (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
                        (signature
                         -> (and=> (upstream-source-signature-urls source)
@@ -430,9 +442,23 @@ SOURCE, an <upstream-source>."
                                         #:key-download key-download)))
          (values version tarball source))))))
 
+(define* (package-update/git-fetch store package source #:key key-download)
+  "Return the version, source code directory, and SOURCE, to update PACKAGE to
+SOURCE, an <upstream-source>."
+  (match source
+    (($ <upstream-source> _ version ref _)
+     (values version
+             (latest-repository-commit
+              store
+              (git-reference-url ref)
+              #:ref `(commit . ,(git-reference-commit ref))
+              #:recursive? (git-reference-recursive? ref))
+             source))))
+
 (define %method-updates
   ;; Mapping of origin methods to source update procedures.
-  `((,url-fetch . ,package-update/url-fetch)))
+  `((,url-fetch . ,package-update/url-fetch)
+    (,git-fetch . ,package-update/git-fetch)))
 
 (define* (package-update store package
                          #:optional (updaters (force %updaters))
@@ -492,9 +518,22 @@ new version string if an update was made, and #f 
otherwise."
                              (origin-hash (package-source package))))
                (old-url     (match (origin-uri (package-source package))
                               ((? string? url) url)
+                              ((? git-reference? ref)
+                               (git-reference-url ref))
                               (_ #f)))
                (new-url     (match (upstream-source-urls source)
-                              ((first _ ...) first)))
+                              ((first _ ...) first)
+                              ((? git-reference? ref)
+                               (git-reference-url ref))
+                              (_ #f)))
+               (old-commit  (match (origin-uri (package-source package))
+                              ((? git-reference? ref)
+                               (git-reference-commit ref))
+                              (_ #f)))
+               (new-commit  (match (upstream-source-urls source)
+                              ((? git-reference? ref)
+                               (git-reference-commit ref))
+                              (_ #f)))
                (file        (and=> (location-file loc)
                                    (cut search-path %load-path <>))))
           (if file
@@ -508,6 +547,9 @@ new version string if an update was made, and #f otherwise."
                                            'filename file))
                     (replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
+                                    ,@(if (and old-commit new-commit)
+                                          `((,old-commit . ,new-commit))
+                                          '())
                                     ,@(if (and old-url new-url)
                                           `((,(dirname old-url) .
                                              ,(dirname new-url)))

signature.asc
Description: This is a digitally signed message part