From debbugs-submit-bounces@debbugs.gnu.org Tue Jan 04 10:09:55 2022 Received: (at 50072) by debbugs.gnu.org; 4 Jan 2022 15:09:55 +0000 Received: from localhost ([127.0.0.1]:38450 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n4lRi-0004GE-H8 for submit@debbugs.gnu.org; Tue, 04 Jan 2022 10:09:55 -0500 Received: from michel.telenet-ops.be ([195.130.137.88]:40150) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n4lRX-0004F8-Ty for 50072@debbugs.gnu.org; Tue, 04 Jan 2022 10:09:48 -0500 Received: from localhost.localdomain ([IPv6:2a02:1811:8c09:9d00:3c5f:2eff:feb0:ba5a]) by michel.telenet-ops.be with bizsmtp id ef9g2600W4UW6Th06f9hSy; Tue, 04 Jan 2022 16:09:41 +0100 From: Maxime Devos To: 50072@debbugs.gnu.org Subject: [PATCH v3 4/4] upstream: Support updating and fetching 'git-fetch' origins. Date: Tue, 4 Jan 2022 15:09:37 +0000 Message-Id: <20220104150937.35872-5-maximedevos@telenet.be> X-Mailer: git-send-email 2.30.2 In-Reply-To: <20220104150937.35872-1-maximedevos@telenet.be> References: <20220104150937.35872-1-maximedevos@telenet.be> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=telenet.be; s=r22; t=1641308982; bh=QiD3exeARFKTO8aRSuAVLT6rafXwAxA/gqtoRI66V1o=; h=From:To:Cc:Subject:Date:In-Reply-To:References; b=JZC8R5URCP5ZP+bpAOhrcs8nDNsielIGDDEdRerK/AKJE1bdPzrrztkQSwa/8BSc5 tUEOXAys2Kuk5Io67N4DL5zJ4JDRpIUru+hQ3Mu8Zkpj/AAFW6IOXVFYX/2YrJdWOz qQyGakHiVBVanAeP9BnE3dLXB61dnegRRoKkw3UxWtXBMc3BEp5A/PLG454xJ7w7+3 EB92ubN+O/GaFXYJur6DT1obwGvl5M4gh/nzSPll7LoAzBNYh2TlP3FLJLrNtAqtbv /VOijX/VEceLrMDxmdYJGDO2wAYZo10rUtc9dzLf/OWHDkGRcFQny26oMyV5dmBZRS QqX28hz7kFZRA== X-Spam-Score: 2.0 (++) X-Spam-Report: Spam detection software, running on the system "debbugs.gnu.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: From: Sarah Morgensen 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. Content analysis details: (2.0 points, 10.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -0.0 RCVD_IN_MSPIKE_H2 RBL: Average reputation (+2) [195.130.137.88 listed in wl.mailspike.net] -0.0 SPF_PASS SPF: sender matches SPF record 0.0 FREEMAIL_FROM Sender email is commonly abused enduser mail provider (maximedevos[at]telenet.be) 2.0 PDS_OTHER_BAD_TLD Untrustworthy TLDs [URI: yoctocell.xyz (xyz)] 0.0 SPF_HELO_NONE SPF: HELO does not publish an SPF Record X-Debbugs-Envelope-To: 50072 Cc: =?UTF-8?q?Ludovic=20Court=C3=A8s?= , Sarah Morgensen , Maxime Devos X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: 0.3 (/) From: Sarah Morgensen 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/git.scm (git-reference->git-checkout): New procedure. * guix/upstream.scm (package-update/git-fetch): New procedure. ()[urls]: Document it can be a 'git-reference'. (%method-updates): Add 'git-fetch' mapping. (update-package-source): Support 'git-reference' sources. (upstream-source-compiler/url-fetch): Split off from ... (upstream-source-compiler): ... this, and call ... (upstream-source-compiler/git-fetch): ... this new procedure if the URL field contains a 'git-reference'. * 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 --- guix/git.scm | 14 ++++++++- guix/import/git.scm | 22 +++++++------ guix/import/minetest.scm | 6 ++-- guix/upstream.scm | 68 +++++++++++++++++++++++++++++++++++----- tests/minetest.scm | 7 ++--- 5 files changed, 93 insertions(+), 24 deletions(-) diff --git a/guix/git.scm b/guix/git.scm index dc2ca1be84..43e85a5026 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2021 Kyle Meyer ;;; Copyright © 2021 Marius Bakke +;;; Copyright © 2022 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,8 @@ #:use-module (guix utils) #:use-module (guix records) #:use-module (guix gexp) + #:autoload (guix git-download) + (git-reference-url git-reference-commit git-reference-recursive?) #:use-module (guix sets) #:use-module ((guix diagnostics) #:select (leave warning)) #:use-module (guix progress) @@ -65,7 +68,9 @@ git-checkout-url git-checkout-branch git-checkout-commit - git-checkout-recursive?)) + git-checkout-recursive? + + git-reference->git-checkout)) (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) @@ -672,6 +677,13 @@ is true, limit to only refs/tags." (commit git-checkout-commit (default #f)) ;#f | tag | commit (recursive? git-checkout-recursive? (default #f))) +(define (git-reference->git-checkout reference) + "Convert the REFERENCE to an equivalent ." + (git-checkout + (url (git-reference-url reference)) + (commit (git-reference-commit reference)) + (recursive? (git-reference-recursive? reference)))) + (define* (latest-repository-commit* url #:key ref recursive? log-port) ;; Monadic variant of 'latest-repository-commit'. (lambda (store) 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 ;;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2022 Maxime Devos ;;; ;;; 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 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 a7bdbfebca..3b2cdcdcac 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -504,9 +504,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..bb6db2cedb 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 ;;; Copyright © 2015 Alex Kost ;;; Copyright © 2019 Ricardo Wurmus +;;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021, 2022 Maxime Devos ;;; ;;; 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 @@ -357,10 +361,20 @@ values: 'interactive' (default), 'always', and 'never'." data url) #f))))))) -(define-gexp-compiler (upstream-source-compiler (source ) - system target) - "Download SOURCE from its first URL and lower it as a fixed-output -derivation that would fetch it." +(define (upstream-source-compiler/git-fetch source system target) + "Lower SOURCE, an using git." + ;; TODO: it would be nice to support provenance tracking, as + ;; in 'upstream-source-compiler/url-fetch'. + ;; + ;; TODO: this causes + ;; + ;; ‘Wrong type to apply: #< url: "https://github.com/minetest-mods/unified_inventory" branch: #f commit: "d6688872c84417d2f61d6f5e607aea39d78920aa" recursive?: #f>’? + ;; (Another error results if it is wrapped in a 'return'.) + (git-reference->git-checkout (upstream-source-urls source))) + +(define (upstream-source-compiler/url-fetch source system target) + "Lower SOURCE, an pointing to a tarball, as a +fixed-output derivation that would fetch it, and verify its authenticity." (mlet* %store-monad ((url -> (first (upstream-source-urls source))) (signature -> (and=> (upstream-source-signature-urls source) @@ -378,6 +392,15 @@ derivation that would fetch it." (url-fetch url 'sha256 hash (store-path-package-name tarball) #:system system)))) +(define-gexp-compiler (upstream-source-compiler (source ) + system target) + "Download SOURCE and verify its authenticity if possible. When feasible, +lower it as a fixed-output derivation that would fetch it, to improve +provenance tracking." + (if (git-reference? (upstream-source-urls source)) + (upstream-source-compiler/git-fetch source system target) + (upstream-source-compiler/url-fetch source system target))) + (define (find2 pred lst1 lst2) "Like 'find', but operate on items from both LST1 and LST2. Return two values: the item from LST1 and the item from LST2 that match PRED." @@ -430,9 +453,24 @@ SOURCE, an ." #:key-download key-download))) (values version tarball source)))))) +(define* (package-update/git-fetch store package source #:key key-download) + "Return the version, checkout, and SOURCE, to update PACKAGE to +SOURCE, an ." + ;; 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 + (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 +530,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 +559,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 is expected")) `(,(upstream-source-package upstream-source) ,(upstream-source-version upstream-source) ,(git-reference-url url) -- 2.30.2