Package: guix-patches;
Reported by: Sarah Morgensen <iskarian <at> mgsn.dev>
Date: Sun, 15 Aug 2021 23:17:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
Message #86 received at 50072 <at> debbugs.gnu.org (full text, mbox):
From: Maxime Devos <maximedevos <at> telenet.be> To: 50072 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org>, Sarah Morgensen <iskarian <at> mgsn.dev>, Maxime Devos <maximedevos <at> telenet.be> Subject: [PATCH v2 4/4] upstream: Support updating 'git-fetch' origins. Date: Sat, 1 Jan 2022 20:39:40 +0000
From: Sarah Morgensen <iskarian <at> mgsn.dev>
Updaters need to be modified to return 'git-reference' objects.
This patch modifies the 'generic-git' and 'minetest' updater,
but others might need to be modified as well.
* guix/upstream.scm (package-update/git-fetch): New procedure.
(<upstream-source>)[urls]: Document it can be a 'git-reference'.
(%method-updates): Add 'git-fetch' mapping.
(update-package-source): Support 'git-reference' sources.
(upstream-source-compiler): Bail out gracefully if the source is a git
origin.
* guix/import/git.scm
(latest-git-tag-version): Always return two values and document that the tag
is returned as well.
(latest-git-release)[urls]: Use the 'git-reference' instead of the
repository URL.
* guix/import/minetest.scm (latest-minetest-release)[urls]: Don't wrap the
'git-reference' in a list.
* tests/minetest.scm (upstream-source->sexp): Adjust to new convention.
Co-authored-by: Maxime Devos <maximedevos <at> telenet.be>
---
guix/import/git.scm | 22 +++++++++------
guix/import/minetest.scm | 6 ++--
guix/upstream.scm | 60 ++++++++++++++++++++++++++++++++++++----
tests/minetest.scm | 7 ++---
4 files changed, 74 insertions(+), 21 deletions(-)
diff --git a/guix/import/git.scm b/guix/import/git.scm
index 1eb219f3fe..4cf404677c 100644
--- a/guix/import/git.scm
+++ b/guix/import/git.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
+;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -34,6 +35,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:export (%generic-git-updater
;; For tests.
@@ -172,21 +174,21 @@ repository at URL."
(values version tag)))))))
(define (latest-git-tag-version package)
- "Given a PACKAGE, return the latest version of it, or #f if the latest version
-could not be determined."
+ "Given a PACKAGE, return the latest version of it and the corresponding git
+tag, or #false and #false if the latest version could not be determined."
(guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "~a for ~a~%")
(condition-message c)
(package-name package))
- #f)
+ (values #f #f))
((eq? (exception-kind c) 'git-error)
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "failed to fetch Git repository for ~a~%")
(package-name package))
- #f))
+ (values #f #f)))
(let* ((source (package-source package))
(url (git-reference-url (origin-uri source)))
(property (cute assq-ref (package-properties package) <>)))
@@ -208,14 +210,16 @@ could not be determined."
"Return an <upstream-source> for the latest release of PACKAGE."
(let* ((name (package-name package))
(old-version (package-version package))
- (url (git-reference-url (origin-uri (package-source package))))
- (new-version (latest-git-tag-version package)))
-
- (and new-version
+ (old-reference (origin-uri (package-source package)))
+ (new-version new-version-tag (latest-git-tag-version package)))
+ (and new-version new-version-tag
(upstream-source
(package name)
(version new-version)
- (urls (list url))))))
+ (urls (git-reference
+ (url (git-reference-url old-reference))
+ (commit new-version-tag)
+ (recursive? (git-reference-recursive? old-reference))))))))
(define %generic-git-updater
(upstream-updater
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index 44671d8480..9df13e45ae 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -503,9 +503,9 @@ or #false if the latest release couldn't be determined."
(upstream-source
(package (package:package-name pkg))
(version (release-version release))
- (urls (list (download:git-reference
- (url (package-repository contentdb-package))
- (commit (release-commit release))))))))
+ (urls (download:git-reference
+ (url (package-repository contentdb-package))
+ (commit (release-commit release)))))))
(define %minetest-updater
(upstream-updater
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 632e9ebc4f..0df2e78d30 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -2,6 +2,8 @@
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2015 Alex Kost <alezost <at> gmail.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado <at> elephly.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos <at> telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,12 +26,14 @@
#:use-module (guix discovery)
#:use-module ((guix download)
#:select (download-to-store url-fetch))
+ #:use-module (guix git-download)
#:use-module (guix gnupg)
#:use-module (guix packages)
#:use-module (guix diagnostics)
#:use-module (guix ui)
#:use-module (guix base32)
#:use-module (guix gexp)
+ #:use-module (guix git)
#:use-module (guix store)
#:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
#:autoload (gcrypt hash) (port-sha256)
@@ -93,7 +97,7 @@
upstream-source?
(package upstream-source-package) ;string
(version upstream-source-version) ;string
- (urls upstream-source-urls) ;list of strings
+ (urls upstream-source-urls) ;list of strings|git-reference
(signature-urls upstream-source-signature-urls ;#f | list of strings
(default #f))
(input-changes upstream-source-input-changes
@@ -361,8 +365,12 @@ 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."
- (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
- (signature
+ (define url
+ (match (upstream-source-urls source)
+ ((first . _) first)
+ (_ (raise (formatted-message
+ (G_ "git origins are unsupported by --with-latest"))))))
+ (mlet* %store-monad ((signature
-> (and=> (upstream-source-signature-urls source)
first))
(tarball ((store-lift download-tarball) url signature)))
@@ -430,9 +438,35 @@ SOURCE, an <upstream-source>."
#:key-download key-download)))
(values version tarball source))))))
+(define (guess-version-transform commit from-version)
+ "Return a one-argument proc that transforms FROM-VERSION to COMMIT, or #f
+if no such transformation could be determined."
+ ;; Just handle prefixes for now, since that's the most common.
+ (if (string-suffix? from-version commit)
+ (let* ((version-length (string-length from-version))
+ (commit-prefix (string-drop-right commit version-length)))
+ (lambda (version)
+ (string-append commit-prefix version)))
+ #f))
+
+(define* (package-update/git-fetch store package source #:key key-download)
+ "Return the version, checkout, and SOURCE, to update PACKAGE to
+SOURCE, an <upstream-source>."
+ ;; TODO: it would be nice to authenticate commits, e.g. with
+ ;; "guix git authenticate" or a list of permitted signing keys.
+ (define ref (upstream-source-urls source)) ; a <git-reference>
+ (values (upstream-source-version source)
+ (latest-repository-commit
+ store
+ (git-reference-url ref)
+ #:ref `(tag-or-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 +526,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 +555,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)))
diff --git a/tests/minetest.scm b/tests/minetest.scm
index 77b9aa928f..cbb9e83889 100644
--- a/tests/minetest.scm
+++ b/tests/minetest.scm
@@ -387,10 +387,9 @@ during a dynamic extent where that package is available on ContentDB."
;; Update detection
(define (upstream-source->sexp upstream-source)
- (define urls (upstream-source-urls upstream-source))
- (unless (= 1 (length urls))
- (error "only a single URL is expected"))
- (define url (first urls))
+ (define url (upstream-source-urls upstream-source))
+ (unless (git-reference? url)
+ (error "a <git-reference> is expected"))
`(,(upstream-source-package upstream-source)
,(upstream-source-version upstream-source)
,(git-reference-url url)
--
2.30.2
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.