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.
View this message in rfc822 format
From: Sarah Morgensen <iskarian <at> mgsn.dev> To: 50072 <at> debbugs.gnu.org Subject: [bug#50072] [PATCH WIP 4/4] upstream: Support updating git-fetch origins. Date: Sun, 15 Aug 2021 16:25:27 -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. --- guix/git-download.scm | 18 +++++++++++++++++- guix/upstream.scm | 41 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 57 insertions(+), 2 deletions(-) diff --git a/guix/git-download.scm b/guix/git-download.scm index 5e624b9ae9..a7bdc16718 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Mathieu Lirzin <mthl <at> gnu.org> ;;; Copyright © 2017 Christopher Baines <mail <at> cbaines.net> ;;; Copyright © 2020 Jakub Kądziołka <kuba <at> kadziolka.net> +;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (guix records) #:use-module (guix packages) #:use-module (guix modules) + #:use-module (guix git) #:autoload (guix build-system gnu) (standard-packages) #:autoload (git bindings) (libgit2-init!) #:autoload (git repository) (repository-open @@ -53,7 +55,9 @@ git-fetch git-version git-file-name - git-predicate)) + git-predicate + + checkout-to-store)) ;;; Commentary: ;;; @@ -287,4 +291,16 @@ absolute file name and STAT is the result of 'lstat'." (#f #f))))) (const #f))) +(define* (checkout-to-store store ref #:key (log (current-error-port))) + "Checkout REF to STORE. Write progress reports to LOG. RECURSIVE? has the +same effect as the same-named parameter of 'latest-repository-commit'." + ;; XXX: (guix git) does not use shallow clones, so this will be slow + ;; for long-running repositories. + (match-record ref <git-reference> + (url commit recursive?) + (latest-repository-commit store url + #:ref `(tag-or-commit . ,commit) + #:recursive? recursive? + #:log-port log))) + ;;; git-download.scm ends here diff --git a/guix/upstream.scm b/guix/upstream.scm index 632e9ebc4f..927260cd89 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -2,6 +2,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ #: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) @@ -430,9 +432,46 @@ 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>." + + (define (uri-update/git old-uri old-version url version) + (let* ((old-commit (git-reference-commit old-uri)) + (transform (guess-version-transform old-commit old-version))) + (and transform + (git-reference + (inherit old-uri) + (url url) + (commit (transform version)))))) + + ;; Only use the first element of URLS. + (match-record source <upstream-source> + (version urls) + (let* ((old-uri (origin-uri (package-source package))) + (old-version (package-version package)) + (new-uri (uri-update/git old-uri old-version + (first urls) version))) + (if new-uri + (values version (checkout-to-store store new-uri) source) + (values #f #f #f))))) + (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)) -- 2.31.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.