#75871 - [PATCH 0/1] Partial version support for 'guix refresh --target-version'.

GNU bug report logs - #75871
[PATCH 0/1] Partial version support for 'guix refresh --target-version'.

Reported by: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>

Date: Sun, 26 Jan 2025 15:01:01 UTC

Severity: normal

Tags: patch

Done: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>

Bug is archived. No further changes may be made.

Message #8 received at 75871 <at> debbugs.gnu.org (full text, mbox):

From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> To: 75871 <at> debbugs.gnu.org Cc: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> Subject: [PATCH] refresh: Add support for partial target versions. Date: Mon, 27 Jan 2025 00:02:21 +0900

* guix/import/utils.scm (find-version): New procedure. * guix/scripts/refresh.scm (<update-spec>) [partial?]: New field. (update-spec-partial?): New accessor. (update-spec): Add a PARTIAL? optional argument. (update-specification->update-spec) <update-spec>: Call with its new PARTIAL? optional argument when FALLBACK-VERSION is provided, i.e. when '--target-version' was used. (update-package): Remove the PACKAGE and VERSION positional arguments, and replace them with UPDATE-SPEC. Update doc. Call `package-update' with its new #:partial-version? argument. (check-for-package-update) <package-latest-release>: Pass the new #:partial-version? argument to it. (guix-refresh) <update-package>: Adjust call accordingly. (show-help): Udate doc. * guix/upstream.scm (package-latest-release): Add #:partial-version? argument, and apply it to the importer call. (package-update): Add #:partial-version?> argument. Update doc. Pass it to the `package-latest-release' call. * guix/gnu-maintenance.scm (rewrite-url): Add #:partial-version? argument. Update doc. Crawl URL for newer compatible versions when provided. (import-html-release): Add #:partial-version? argument, and pass it to the `rewrite-url' call. Use `find-version' to find the best version. (import-release, import-ftp-release, import-gnu-release) (import-release*): Add #:partial-version? argument and honor it. (import-html-updatable-release): Add #:partial-version? argument, and pass it to the `import-html-release' call. * guix/import/gnome.scm (import-gnome-release) <#:partial-version?>: Add new argument and honor it. * guix/import/texlive.scm (latest-texlive-tag): Rename to... (texlive-tags): ... this, and have it return all tags. (texlive->guix-package): Adjust accordingly. (latest-release): Add a #:partial-version? argument. Update doc. * guix/import/stackage.scm (latest-lts-release): New #:partial-version? argument. * guix/import/pypi.scm (import-release): New #:partial-version? argument; pass it to `pypi-package->upstream-source'. * guix/import/opam.scm (latest-release): New #:partial-version? argument. * guix/import/minetest.scm (latest-minetest-release): New #:partial-version? argument. (pypi-package->upstream-source): New #:partial-version? argument. Update doc. * guix/import/launchpad.scm (latest-released-version): Rename to... (release-versions): ... this, making it return all versions. (import-release) <#:partial-version?>: New argument. * guix/import/kde.scm (import-kde-release) <#:partial-version?>: New argument. Update doc. Refactor to honor argument. * guix/import/hexpm.scm (lookup-hexpm): Update doc. (hexpm-latest-release): Rename to... (hexpm-releases): ... this; return all release strings. (hexpm->guix-package): Adjust accordingly. (import-release): Add and honor a #:partial-version? argument. Update doc. * guix/import/hackage.scm (import-release): New #:partial-version? argument. * guix/import/cpan.scm (latest-release): New #:partial-version? argument. * guix/import/crate.scm (max-crate-version-of-semver): Improve doc. (import-release): Add a #:partial-version? argument and honor it. * guix/import/egg.scm (find-latest-version): Rename to... (get-versions): ... this, returning all versions. (egg-metadata): Adjust accordingly. (egg->guix-package): Likewise. (import-release): Add a new #:partial-version? argument and honor it. * guix/import/elpa.scm (latest-release): New #:partial-version? argument. * guix/import/gem.scm (get-versions): New procedure. (import-release): Add a new #:partial-version? argument and honor it. * guix/import/git.scm (version-mapping): Update doc; streamline a bit. (latest-tag): Rename to... (get-tags): ... this, dropping the #:version keyword and returning the complete tags alist. Update doc. (latest-git-tag-version): Rename to... (get-package-tags): ... this, returning the complete tags alist of the package. Update doc. (import-git-release): Add a new #:partial-version? argument and honor it. Update doc. * guix/import/github.scm (latest-released-version): Rename to... (get-package-tags): ... this, returning all tags. Update doc. (import-release): Add a new #:partial-version? argument and honor it. * guix/import/cran.scm (latest-cran-release) (latest-bioconductor-release): Add #:partial-version? argument. * guix/import/composer.scm (latest-version): Delete procedure. (composer-fetch): Add #:partial-version? keyword and honor it. Update doc. (import-release): Likewise. * guix/import/test.scm (import-release): Add #:partial-version? argument. * tests/guix-refresh.sh: Add test. * tests/gem.scm (test-foo-versions-json): New variable. (package-latest-release): Mock new URL. * tests/import-git.scm (latest-git-tag-version): New procedure. * tests/gnu-maintenance.scm (libuv-dist-html) (libuv-dist-1.46.0-html, libuv-dist-1.44.2-html) (libuv-html-data): New variables. (mock-http-fetch/cached): New procedure. ("rewrite-url, without to-version"): Rewrite using the above. ("rewrite-url, partial to-version"): New test. * doc/guix.texi <"Invoking guix refresh">: Update doc. Change-Id: I092a58b57ac42e54a2fa55e7761e8c6993af8ad4 --- doc/guix.texi | 12 +++ guix/gnu-maintenance.scm | 120 ++++++++++++++----------- guix/import/composer.scm | 59 ++++++------ guix/import/cpan.scm | 2 +- guix/import/cran.scm | 4 +- guix/import/crate.scm | 51 ++++++----- guix/import/egg.scm | 33 +++---- guix/import/elpa.scm | 2 +- guix/import/gem.scm | 29 ++++-- guix/import/git.scm | 103 +++++++++------------ guix/import/github.scm | 114 +++++++++++------------ guix/import/gnome.scm | 50 ++++------- guix/import/hackage.scm | 2 +- guix/import/hexpm.scm | 42 +++++---- guix/import/kde.scm | 57 ++++++------ guix/import/launchpad.scm | 36 ++++---- guix/import/minetest.scm | 2 +- guix/import/opam.scm | 2 +- guix/import/pypi.scm | 25 ++++-- guix/import/stackage.scm | 2 +- guix/import/test.scm | 15 ++-- guix/import/texlive.scm | 38 ++++---- guix/import/utils.scm | 20 ++++- guix/scripts/refresh.scm | 185 ++++++++++++++++++++------------------ guix/upstream.scm | 26 +++--- tests/gem.scm | 22 +++++ tests/gnu-maintenance.scm | 65 +++++++++++--- tests/guix-refresh.sh | 10 ++- tests/import-git.scm | 4 + 29 files changed, 629 insertions(+), 503 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 9a53bdcd37..cc03dda4ee 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14961,6 +14961,7 @@ Invoking guix refresh @dots{} @end example +@cindex target version, guix refresh In some specific cases, you may have many packages specified via a manifest or a module selection which should all be updated together; for these cases, the @option{--target-version} option can be provided to have @@ -14981,6 +14982,17 @@ Invoking guix refresh @dots{} @end example +@cindex partial target version, guix refresh +The @option{--target-version} option accepts partial version prefixes, +which can be useful to update to the latest major or major-minor +prefixed version: + +@example +$ guix refresh qtbase@@5 qtdeclarative@@5 --target-version=5 +gnu/packages/qt.scm:1472:13: qtdeclarative would be upgraded from 5.15.8 to 5.15.10 +gnu/packages/qt.scm:452:13: qtbase would be upgraded from 5.15.8 to 5.15.10 +@end example + Sometimes the upstream name differs from the package name used in Guix, and @command{guix refresh} needs a little help. Most updaters honor the @code{upstream-name} property in package definitions, which can be used diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index ee4882326f..f26d8c5fbc 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita <at> karetnikov.org> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune <at> gmail.com> ;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be> -;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> +;;; Copyright © 2023, 2025 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,7 +44,7 @@ (define-module (guix gnu-maintenance) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) - #:autoload (guix import utils) (false-if-networking-error) + #:autoload (guix import utils) (false-if-networking-error find-version) #:autoload (zlib) (call-with-gzip-input-port) #:autoload (htmlprag) (html->sxml) ;from Guile-Lib #:export (gnu-package-name @@ -346,12 +346,15 @@ (define* (releases project (define* (import-ftp-release project #:key - (version #f) + version + partial-version? (server "ftp.gnu.org") (directory (string-append "/gnu/" project)) (file->signature (cut string-append <> ".sig"))) "Return an <upstream-source> for the latest release of PROJECT on SERVER -under DIRECTORY, or #f. Optionally include a VERSION string to fetch a specific version. +under DIRECTORY, or #f. Optionally include a VERSION string to fetch a +specific version, which may be marked as partially specified via +PARTIAL-VERSION?. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be useful to reuse connections. @@ -417,7 +420,9 @@ (define* (import-ftp-release project (and (release-file? project file) (file->source directory file))) (_ #f)) - entries))) + entries)) + (versions (map upstream-source-version releases)) + (version (find-version versions version partial-version?))) ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. @@ -440,14 +445,17 @@ (define* (import-ftp-release project (define* (import-release package #:key - (version #f) + version + partial-version? (server "ftp.gnu.org") (directory (string-append "/gnu/" package))) "Return the <upstream-source> for the latest version of PACKAGE or #f. PACKAGE must be the canonical name of a GNU package. Optionally include a -VERSION string to fetch a specific version." +VERSION string to fetch a specific version, which may be marked as partially +specified via PARTIAL-VERSION?." (import-ftp-release package #:version version + #:partial-version? partial-version? #:server server #:directory directory)) @@ -463,7 +471,7 @@ (define-syntax-rule (false-if-ftp-error exp) (close-port port)) #f))) -(define* (import-release* package #:key (version #f)) +(define* (import-release* package #:key version partial-version?) "Like 'import-release', but (1) take a <package> object, and (2) ignore FTP errors that might occur when PACKAGE is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that name (this is the case for @@ -474,6 +482,7 @@ (define* (import-release* package #:key (version #f)) (false-if-ftp-error (import-release (package-upstream-name package) #:version version + #:partial-version? partial-version? #:server server #:directory directory))))) @@ -561,16 +570,23 @@ (define (strip-trailing-slash s) ;;; TODO: Extend to support the RPM and GNOME version schemes? (define %version-rx "[0-9.]+") -(define* (rewrite-url url version #:key to-version) +(define* (rewrite-url url version #:key to-version partial-version?) "Rewrite URL so that the URL path components matching the current VERSION or VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found by crawling the corresponding URL directories. Alternatively, when TO-VERSION -is specified, rewrite version matches directly to it without crawling URL. +is specified, rewrite version matches directly to it without crawling URL. If +TO-VERSION is provided and PARTIAL-VERSION? set to #t, then crawl URL to find +the newest compatible release (one that is prefixed by TO-VERSION). For example, the URL \"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be rewritten to something like -\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"." +\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\". + +With TO-VERSION set to \"1.49\" and PARTIAL-VERSION? set to #t, the URL +\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be +rewritten to something like +\"https://dist.libuv.org/dist/v1.49.2/libuv-v1.49.2.tar.gz\"." ;; XXX: major-minor may be #f if version is not a triplet but a single ;; number such as "2". (let* ((major-minor (false-if-exception (version-major+minor version))) @@ -590,14 +606,15 @@ (define* (rewrite-url url version #:key to-version) (reverse (fold (lambda (s parents) - (if to-version + (if (and to-version (not partial-version?)) ;; Direct rewrite case; the archive is assumed to exist. (let ((u (string-replace-substring s version to-version))) (cons (if (and major-minor to-major-minor) (string-replace-substring u major-minor to-major-minor) u) parents)) - ;; More involved HTML crawl case. + ;; More involved HTML crawl case to get the latest version or a + ;; partial to-version. (let* ((pattern (if major-minor (format #f "(~a|~a)" version major-minor) (format #f "(~a)" version))) @@ -620,15 +637,14 @@ (define* (rewrite-url url version #:key to-version) (m (string-match pattern l)) (v (match:substring m 1))) (cons v l))) - links))) - ;; Retrieve the item having the largest version. - (if (null? candidates) - parents - (cons (cdr (first (sort candidates - (lambda (x y) - (version>? (car x) - (car y)))))) - parents))) + links)) + (versions (map car candidates)) + (version (find-version versions to-version + partial-version?))) + ;; Retrieve the item having the greatest version. + (if version + (cons (assoc-ref candidates version) parents) + parents)) ;XXX: bogus case; throw an error? ;; No version found in path component; continue. (cons s parents))))) (reverse url-prefix-components) @@ -639,12 +655,14 @@ (define* (import-html-release base-url package #:key rewrite-url? version + partial-version? (directory (string-append "/" (package-upstream-name package))) file->signature) "Return an <upstream-source> for the latest release of PACKAGE under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to fetch a -specific version. +specific version, which may be marked as partially specified via +PARTIAL-VERSION?. BASE-URL should be the URL of an HTML page, typically a directory listing as found on 'https://kernel.org/pub'. @@ -663,7 +681,8 @@ (define* (import-html-release base-url package base-url (string-append base-url directory "/"))) (url (if rewrite-url? - (rewrite-url url current-version #:to-version version) + (rewrite-url url current-version #:to-version version + #:partial-version? partial-version?) url)) (links (map (cut canonicalize-url <> url) (url->links url)))) @@ -695,23 +714,18 @@ (define* (import-html-release base-url package (lambda (url) (list (uri-mirror-rewrite url)))))))))) (define candidates - (filter-map url->release links)) - - (match candidates - (() #f) - ((first . _) - (if version - ;; Find matching release version and return it. - (find (lambda (upstream) - (string=? (upstream-source-version upstream) version)) - (coalesce-sources candidates)) - ;; Select the most recent release and return it. - (reduce (lambda (r1 r2) - (if (version>? (upstream-source-version r1) - (upstream-source-version r2)) - r1 r2)) - first - (coalesce-sources candidates))))))) + (coalesce-sources (filter-map url->release links))) + + (define versions + (map upstream-source-version candidates)) + + (define new-version + (find-version versions version partial-version?)) + + (and new-version + (find (compose (cut string=? new-version <>) + upstream-source-version) + candidates)))) ;;; @@ -743,7 +757,7 @@ (define ftp.gnu.org-files (call-with-gzip-input-port port (compose string->lines get-string-all)))))) -(define* (import-gnu-release package #:key (version #f)) +(define* (import-gnu-release package #:key version partial-version?) "Return the latest release of PACKAGE, a GNU package available via ftp.gnu.org. Optionally include a VERSION string to fetch a specific version. @@ -776,12 +790,15 @@ (define* (import-gnu-release package #:key (version #f)) (string-contains file directory) (release-file? name (basename file)))) files)) - ;; find latest version - (version (or version - (and (not (null? relevant)) - (tarball->version - (find-latest-tarball-version relevant))))) - ;; find tarballs matching this version + (versions (delay (sort (delete-duplicates + (map tarball->version relevant)) + version>?))) + (version (or (and version partial-version? + (find (cut version-prefix? version <>) + (force versions))) + version + (first (force versions)))) + ;; Find tarballs matching this version. (tarballs (filter (lambda (file) (string=? version (tarball->version file))) relevant))) @@ -998,11 +1015,11 @@ (define (html-updatable-package? package) (or (assoc-ref (package-properties package) 'release-monitoring-url) ((url-predicate http-url?) package))) -(define* (import-html-updatable-release package #:key (version #f)) +(define* (import-html-updatable-release package #:key version partial-version?) "Return the latest release of PACKAGE else #f. Do that by crawling the HTML page of the directory containing its source tarball. Optionally include a -VERSION string to fetch a specific version." - +VERSION string to fetch a specific version; which may be partially provided +when PARTIAL-VERSION? is #t." (define (expand-uri uri) (match uri ((and (? string?) (? (cut string-prefix? "mirror://" <>) url)) @@ -1029,6 +1046,7 @@ (define* (import-html-updatable-release package #:key (version #f)) (import-html-release base package #:rewrite-url? #t #:version version + #:partial-version? partial-version? #:directory directory)))) (define %gnu-updater diff --git a/guix/import/composer.scm b/guix/import/composer.scm index abc9023be4..ba70e89c4f 100644 --- a/guix/import/composer.scm +++ b/guix/import/composer.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Julien Lepiller <julien <at> lepiller.eu> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +37,7 @@ (define-module (guix import composer) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:export (composer->guix-package @@ -58,10 +60,6 @@ (define (fix-version version) (substring version 1)) (else version))) -(define (latest-version versions) - (fold (lambda (a b) (if (version>? (fix-version a) (fix-version b)) a b)) - (car versions) versions)) - (define (json->require dict) (if dict (let loop ((result '()) (require dict)) @@ -102,31 +100,25 @@ (define (valid-version? v) (not (string-contains d "beta")) (not (string-contains d "rc"))))) -(define* (composer-fetch name #:key (version #f)) +(define* (composer-fetch name #:key version partial-version?) "Return a composer-package representation of the Composer metadata for the -package NAME with optional VERSION, or #f on failure." - (let* ((url (string-append (%composer-base-url) "/p/" name ".json")) - (packages (and=> (json-fetch url) - (lambda (pkg) - (let ((pkgs (assoc-ref pkg "packages"))) - (or (assoc-ref pkgs name) pkg)))))) - (if packages - (json->composer-package - (if version - (assoc-ref packages version) - (cdr - (fold - (lambda (new cur-max) - (match new - (((? valid-version? version) . tail) - (if (version>? (fix-version version) - (fix-version (car cur-max))) - (cons* version tail) - cur-max)) - (_ cur-max))) - (cons* "0.0.0" #f) - packages)))) - #f))) +package NAME with optional VERSION, or #f on failure. VERSION may be gien as +version prefix if PARTIAL-VERSION? is #t." + (and-let* ((url (string-append (%composer-base-url) "/p/" name ".json")) + (packages (and=> (json-fetch url) + (lambda (pkg) + (let ((pkgs (assoc-ref pkg "packages"))) + (or (assoc-ref pkgs name) pkg))))) + (all-versions (map car packages)) + (valid-versions (filter valid-version? all-versions)) + (version (or (find-version valid-versions version partial-version?) + (and version + ;; If the user-provided VERSION could not be + ;; found, fallback to look through all + ;; versions. + (find-version all-versions version + partial-version?))))) + (json->composer-package (assoc-ref packages version)))) (define (php-package-name name) "Given the NAME of a package on Packagist, return a Guix-compliant name for @@ -246,10 +238,15 @@ (define (dependency->input dependency type) (downstream-name (php-package-name dependency)) (type type))) -(define* (import-release package #:key (version #f)) - "Return an <upstream-source> for VERSION or the latest release of PACKAGE." +(define* (import-release package #:key version partial-version?) + "Return an <upstream-source> for VERSION or the latest release of PACKAGE. +If PARTIAL-VERSION? is #t, the provided VERSION may be a partial version +prefix." (let* ((php-name (guix-package->composer-name package)) - (composer-package (composer-fetch php-name #:version version))) + (composer-package (composer-fetch php-name + #:version version + #:partial-version? + partial-version?))) (if composer-package (upstream-source (package (composer-package-name composer-package)) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 85e5e69098..5f06aaae90 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -328,7 +328,7 @@ (define cpan-package? ")")))) (url-predicate (cut regexp-exec cpan-rx <>)))) -(define* (latest-release package #:key (version #f)) +(define* (latest-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE." (when version (raise diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 3bea9439e1..4825af12a5 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1028,7 +1028,7 @@ (define (package->upstream-name package) (_ #f))) (_ #f))))) -(define* (latest-cran-release pkg #:key (version #f)) +(define* (latest-cran-release pkg #:key version partial-version?) "Return an <upstream-source> for the latest release of the package PKG." (when version (error @@ -1051,7 +1051,7 @@ (define* (latest-cran-release pkg #:key (version #f)) (urls (cran-uri upstream-name version)) (inputs (cran-package-inputs meta 'cran)))))) -(define* (latest-bioconductor-release pkg #:key (version #f)) +(define* (latest-bioconductor-release pkg #:key version partial-version?) "Return an <upstream-source> for the latest release of the package PKG." (when version (error diff --git a/guix/import/crate.scm b/guix/import/crate.scm index d790126ef6..3eda9fe986 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2023 Simon Tournier <zimon.toutoune <at> gmail.com> ;;; Copyright © 2023, 2024 Efraim Flashner <efraim <at> flashner.co.il> ;;; Copyright © 2023, 2024 David Elsing <david.elsing <at> posteo.net> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; Copyright © 2025 Herman Rimm <herman <at> rimm.ee> ;;; ;;; This file is part of GNU Guix. @@ -272,8 +273,9 @@ (define (min-element l less) (loop curr remaining) (loop next remaining)))))) -(define (max-crate-version-of-semver semver-range range) - "Returns a <crate-version> of the highest version within the semver range." +(define (max-crate-version-of-semver semver-range versions) + "Returns the <crate-version> of the highest version found in VERSIONS that +satisfies SEMVER-RANGE." (define (crate->semver crate) (string->semver (crate-version-number crate))) @@ -281,7 +283,7 @@ (define (max-crate-version-of-semver semver-range range) (min-element (filter (lambda (crate) (semver-range-contains? semver-range (crate->semver crate))) - range) + versions) (lambda args (apply semver>? (map crate->semver args))))) @@ -482,25 +484,34 @@ (define (crate-name->package-name name) (define crate-package? (url-predicate crate-url?)) -(define* (import-release package #:key (version #f)) - "Return an <upstream-source> for the latest release of PACKAGE. Optionally -include a VERSION string to fetch a specific version." +(define* (import-release package #:key version partial-version?) + "Return an <upstream-source> for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version, which may be a partial +prefix when PARTIAL-VERSION? is #t." (let* ((crate-name (guix-package->crate-name package)) (crate (lookup-crate crate-name)) - (version (or version - (let ((max-crate-version - (max-crate-version-of-semver - (string->semver-range - (string-append "^" (package-version package))) - (nonyanked-crate-versions crate)))) - (and=> max-crate-version - crate-version-number))))) - (if version - (upstream-source - (package (package-name package)) - (version version) - (urls (list (crate-uri crate-name version)))) - #f))) + (versions (delay (nonyanked-crate-versions crate))) + (find-max-minor-patch-version (lambda (base-version) + (max-crate-version-of-semver + (string->semver-range + (string-append + "^" base-version)) + (force versions)))) + (version (cond + ((and version partial-version?) ;partial version + (and=> (find-max-minor-patch-version version) + crate-version-number)) + ((and version (not partial-version?)) ;exact version + version) + (else ;latest version + (and=> (find-max-minor-patch-version + (package-version package)) + crate-version-number))))) + (and version + (upstream-source + (package (package-name package)) + (version version) + (urls (list (crate-uri crate-name version))))))) (define %crate-updater (upstream-updater diff --git a/guix/import/egg.scm b/guix/import/egg.scm index a87de1453e..849e559ad6 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> ;;; Copyright © 2024 Ekaitz Zarraga <ekaitz <at> elenq.tech> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ (define-module (guix import egg) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-71) #:use-module (gcrypt hash) #:use-module (guix git) @@ -99,12 +101,9 @@ (define (egg-directory name) (let ((eggs-directory (eggs-repository))) (string-append eggs-directory "/" name))) -(define (find-latest-version name) - "Get the latest version of the egg NAME." - (let ((directory (scandir (egg-directory name)))) - (if directory - (last directory) - #f))) +(define (get-versions name) + "Get the release versions of the egg NAME." + (or (scandir (egg-directory name)) '())) (define* (egg-metadata name #:key (version #f) (file #f)) "Return the package metadata file for the egg NAME at version VERSION, or if @@ -112,7 +111,7 @@ (define* (egg-metadata name #:key (version #f) (file #f)) (call-with-input-file (or file (string-append (egg-directory name) "/" (or version - (find-latest-version name)) + (first (get-versions name))) "/" name ".egg")) read)) @@ -188,7 +187,7 @@ (define* (egg->guix-package name version #:key (file #f) (source #f) (if (not egg-content) (values #f '()) ; egg doesn't exist (let* ((version* (or (assoc-ref egg-content 'version) - (find-latest-version name))) + (first (get-versions name)))) (version (if (list? version*) (first version*) version*)) (source-url (if source #f `(egg-uri ,name version))) (tarball (if source @@ -333,16 +332,18 @@ (define* (egg-recursive-import package-name #:optional version) ;;; Updater. ;;; -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return an @code{<upstream-source>} for the latest release of PACKAGE. -Optionally include a VERSION string to fetch a specific version." +Optionally fetch a specific VERSION string, which may be a version prefix when +PARTIAL-VERSION? is #t." (let* ((egg-name (guix-package->egg-name package)) - (version (or version (find-latest-version egg-name))) - (source-url (egg-uri egg-name version))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list source-url))))) + (versions (get-versions egg-name)) + (version (find-version versions version partial-version?))) + (and version + (upstream-source + (package (package-name package)) + (version version) + (urls (list (egg-uri egg-name version))))))) (define %egg-updater (upstream-updater diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 62b1d645ac..c2cdd1005d 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -422,7 +422,7 @@ (define (guix-package->elpa-name package) (string-drop (package-name package) 6) (package-name package)))) -(define* (latest-release package #:key (version #f)) +(define* (latest-release package #:key version partial-version?) "Return an <upstream-release> for the latest release of PACKAGE." (define name (guix-package->elpa-name package)) (define repo (elpa-repository package)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 56cbc681a1..46024b9d6a 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev> ;;; Copyright © 2022 Taiju HIGASHI <higashi <at> taiju.info> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ (define-module (guix import gem) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (json) #:use-module (guix import utils) #:use-module (guix import json) @@ -35,6 +37,7 @@ (define-module (guix import gem) #:use-module (guix base16) #:use-module (guix base32) #:use-module ((guix build-system ruby) #:select (rubygems-uri)) + #:use-module ((guix utils) #:select (version>? version-prefix?)) #:export (gem->guix-package %gem-updater gem-recursive-import)) @@ -90,6 +93,15 @@ (define* (rubygems-fetch name #:optional version) (string-append "https://rubygems.org/api/v1/gems/" name ".json"))) json->gem)) +(define (get-versions name) + "Return all the versions for the gem NAME, sorted in decreasing order." + (let* ((url (string-append "https://rubygems.org/api/v1/versions/" + name ".json")) + (versions-data (json-fetch url))) + (sort (map (cut assoc-ref <> "number") + (vector->list versions-data)) + version>?))) + (define (ruby-package-name name) "Given the NAME of a package on RubyGems, return a Guix-compliant name for the package." @@ -172,7 +184,7 @@ (define (string->license str) (define gem-package? (url-prefix-predicate "https://rubygems.org/downloads/")) -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE." (let* ((gem-name (guix-package->gem-name package)) (gem (rubygems-fetch gem-name)) @@ -184,13 +196,14 @@ (define* (import-release package #:key (version #f)) (ruby-package-name name)) (type 'propagated)))) (gem-dependencies-runtime (gem-dependencies gem)))) - (version (or version (gem-version gem))) - (url (rubygems-uri gem-name version))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list url)) - (inputs inputs)))) + (versions (get-versions gem-name)) + (version (find-version versions version partial-version?))) + (and version + (upstream-source + (package (package-name package)) + (version version) + (urls (list (rubygems-uri gem-name version))) + (inputs inputs))))) (define %gem-updater (upstream-updater diff --git a/guix/import/git.scm b/guix/import/git.scm index 305b2fc43f..8d443895cf 100644 --- a/guix/import/git.scm +++ b/guix/import/git.scm @@ -26,7 +26,7 @@ (define-module (guix import git) #:use-module (guix git-download) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module (guix utils) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -34,10 +34,7 @@ (define-module (guix import git) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-71) - #:export (%generic-git-updater - - ;; For tests. - latest-git-tag-version)) + #:export (%generic-git-updater)) ;;; Commentary: ;;; @@ -121,7 +118,9 @@ (define* (version-mapping tags #:key prefix suffix delim pre-releases?) ;; with "." pre-release-rx suffix-rx)) - + (define (pre-release? tag) + (any (cut regexp-exec <> tag) + %pre-release-rx)) (define (get-version tag) (let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) @@ -135,30 +134,20 @@ (define* (version-mapping tags #:key prefix suffix delim pre-releases?) (string-append version (match:substring tag-match 3)) version))))) - (define (entry<? a b) - (eq? (version-compare (car a) (car b)) '<)) - - (define (pre-release? tag) - (any (cut regexp-exec <> tag) - %pre-release-rx)) - - (stable-sort (filter-map (lambda (tag) - (let ((version (get-version tag))) - (and version - (or pre-releases? - (not (pre-release? version))) - (cons version tag)))) - tags) - entry<?)) - -(define* (latest-tag url - #:key prefix suffix delim pre-releases? (version #f)) - "Return the latest version and corresponding tag available from the Git -repository at URL. Optionally include a VERSION string to fetch a specific -version." + (filter-map (lambda (tag) + (let ((version (get-version tag))) + (and version + (or pre-releases? + (not (pre-release? version))) + (cons version tag)))) + tags)) + +(define* (get-tags url #:key prefix suffix delim pre-releases?) + "Return a alist of the Git tags available from URL. The tags are keyed by +their version, a mapping derived from their name." (let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) (remote-refs url #:tags? #t))) - (versions->tags + (versions+tags (version-mapping tags #:prefix prefix #:suffix suffix @@ -167,47 +156,38 @@ (define* (latest-tag url (cond ((null? tags) (git-no-tags-error)) - ((null? versions->tags) + ((null? versions+tags) (git-no-valid-tags-error)) (else - (let ((versions (if version - (filter (match-lambda - ((candidate-version . tag) - (string=? version candidate-version))) - versions->tags) - versions->tags))) - (if (null? versions) - (values #f #f) - (match (last versions) - ((version . tag) - (values version tag))))))))) - -(define* (latest-git-tag-version package #:key (version #f)) - "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. -Optionally include a VERSION string to fetch a specific version." + versions+tags)))) ;already sorted + +(define* (get-package-tags package) + "Given a PACKAGE, return all its known tags, an alist keyed by the tags +associated versions. " (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)) - (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)) - (values #f #f))) + '())) (let* ((source (package-source package)) (url (git-reference-url (origin-uri source))) (property (cute assq-ref (package-properties package) <>))) - (latest-tag url - #:version version - #:prefix (property 'release-tag-prefix) - #:suffix (property 'release-tag-suffix) - #:delim (property 'release-tag-version-delimiter) - #:pre-releases? (property 'accept-pre-releases?))))) + (get-tags url + #:prefix (property 'release-tag-prefix) + #:suffix (property 'release-tag-suffix) + #:delim (property 'release-tag-version-delimiter) + #:pre-releases? (property 'accept-pre-releases?))))) + +;; Prevent Guile from inlining this procedure so we can use it in tests. +(set! get-package-tags get-package-tags) (define (git-package? package) "Return true if PACKAGE is hosted on a Git repository." @@ -217,21 +197,24 @@ (define (git-package? package) (git-reference? (origin-uri origin)))) (_ #f))) -(define* (import-git-release package #:key (version #f)) +(define* (import-git-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE. -Optionally include a VERSION string to fetch a specific version." +Optionally include a VERSION string to fetch a specific version, which may be +a version prefix when PARTIAL-VERSION? is #t." (let* ((name (package-name package)) (old-version (package-version package)) (old-reference (origin-uri (package-source package))) - (new-version new-version-tag - (latest-git-tag-version package #:version version))) - (and new-version new-version-tag + (tags (get-package-tags package)) + (versions (map car tags)) + (version (find-version versions version partial-version?)) + (tag (assoc-ref tags version))) + (and version (upstream-source (package name) - (version new-version) + (version version) (urls (git-reference (url (git-reference-url old-reference)) - (commit new-version-tag) + (commit tag) (recursive? (git-reference-recursive? old-reference)))))))) (define %generic-git-updater diff --git a/guix/import/github.scm b/guix/import/github.scm index 7be29ca151..00d362822f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> ;;; Copyright © 2023 Giacomo Leidi <goodoldpaul <at> autistici.org> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,7 +31,8 @@ (define-module (guix import github) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-71) - #:use-module (guix utils) + #:use-module ((guix import utils) #:select (find-version)) + #:use-module ((guix utils) #:select (string-replace-substring)) #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module ((guix ui) #:select (display-hint)) @@ -246,40 +248,49 @@ (define (fetch-releases-or-tags url) #:headers headers)))) (match result (#() - ;; We got the empty list, presumably because the user didn't use GitHub's - ;; "release" mechanism, but hopefully they did use Git tags. + ;; We got the empty list, presumably because the user + ;; didn't use GitHub's "release" mechanism, but hopefully + ;; they did use Git tags. (json->scm (http-fetch tag-url #:port connection #:keep-alive? #t #:headers headers))) (x x))))))))) -(define* (latest-released-version url package-name #:key (version #f)) - "Return the newest released version and its tag given a string URL like -'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of -the package e.g. 'bedtools2'. Return #f (two values) if there are no -releases. +(define* (get-package-tags package) + "Return an alist of tags keyed by their version for PACKAGE, a <package> +object." + (define (github-uri uri) + (match uri + ((? string? url) + url) ;surely a github.com URL + ((? download:git-reference? ref) + (download:git-reference-url ref)) + ((urls ...) + (find (cut string-contains <> "github.com") urls)))) -Optionally include a VERSION string to fetch a specific version." (define (pre-release? x) (assoc-ref x "prerelease")) + (define source-uri + (github-uri (origin-uri (package-source package)))) + ;; This procedure returns (version . tag) pair, or #f ;; if RELEASE doesn't seyem to correspond to a version. (define (release->version release) - (let ((tag (or (assoc-ref release "tag_name") ;a "release" - (assoc-ref release "name"))) ;a tag - (name-length (string-length package-name))) + (let* ((tag (or (assoc-ref release "tag_name") ;a "release" + (assoc-ref release "name"))) ;a tag + (name (package-upstream-name package)) + (name-length (string-length name))) (cond - ;; some tags include the name of the package e.g. "fdupes-1.51" - ;; so remove these + ;; Some tags include the name of the package e.g. "fdupes-1.51"; remove + ;; these. ((and (< name-length (string-length tag)) - (string=? (string-append package-name "-") + (string=? (string-append name "-") (substring tag 0 (+ name-length 1)))) (cons (substring tag (+ name-length 1)) tag)) - ;; some tags start with a "v" e.g. "v0.25.0" - ;; or with the word "version" e.g. "version.2.1" - ;; where some are just the version number + ;; Some tags start with a "v" e.g. "v0.25.0" or with the word "version" + ;; e.g. "version.2.1" where some are just the version number. ((string-prefix? "version" tag) (cons (if (char-set-contains? char-set:digit (string-ref tag 7)) (substring tag 7) @@ -294,53 +305,32 @@ (define* (latest-released-version url package-name #:key (version #f)) (cons tag tag)) (else #f)))) - (match (and=> (fetch-releases-or-tags url) vector->list) - (#f (values #f #f)) + (match (and=> (fetch-releases-or-tags source-uri) vector->list) + (#f '()) (json - (let ((releases (filter-map release->version - (match (remove pre-release? json) - (() json) ; keep everything - (releases releases))))) - (match (if version - ;; Find matching release version. - (filter (match-lambda - ((candidate-version . tag) - (string=? version candidate-version))) - releases) - ;; Sort releases descending. - (sort releases - (lambda (x y) (version>? (car x) (car y))))) - (((latest-version . tag) . _) (values latest-version tag)) - (() (values #f #f))))))) + (filter-map release->version + (match (remove pre-release? json) + (() json) ;keep everything + (releases releases)))))) -(define* (import-release pkg #:key (version #f)) +(define* (import-release pkg #:key version partial-version?) "Return an <upstream-source> for the latest release of PKG. -Optionally include a VERSION string to fetch a specific version." - (define (github-uri uri) - (match uri - ((? string? url) - url) ;surely a github.com URL - ((? download:git-reference? ref) - (download:git-reference-url ref)) - ((urls ...) - (find (cut string-contains <> "github.com") urls)))) - +Optionally include a VERSION string to fetch a specific version, which may be +a partial version prefix if PARTIAL-VERSION? is #t." (let* ((original-uri (origin-uri (package-source pkg))) - (source-uri (github-uri original-uri)) - (name (package-upstream-name pkg)) - (newest-version version-tag - (latest-released-version source-uri name - #:version version))) - (if newest-version - (upstream-source - (package name) - (version newest-version) - (urls (if (download:git-reference? original-uri) - (download:git-reference - (inherit original-uri) - (commit version-tag)) - (list (updated-github-url pkg newest-version))))) - #f))) ; On GitHub but no proper releases + (tags (get-package-tags pkg)) + (versions (map car tags)) + (version (find-version versions version partial-version?)) + (tag (assoc-ref tags version))) + (and version + (upstream-source + (package (package-upstream-name pkg)) + (version version) + (urls (if (download:git-reference? original-uri) + (download:git-reference + (inherit original-uri) + (commit tag)) + (list (updated-github-url pkg version)))))))) (define %github-updater (upstream-updater @@ -348,5 +338,3 @@ (define %github-updater (description "Updater for GitHub packages") (pred github-package?) (import import-release))) - - diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 3ba8ae02e5..ec7a498dc8 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2019, 2021, 2024 Ludovic Courtès <ludo <at> gnu.org> -;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> +;;; Copyright © 2022, 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. @@ -19,14 +19,15 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import gnome) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (guix upstream) - #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix http-client) #:use-module (guix diagnostics) #:use-module (guix i18n) #:use-module (json) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (ice-9 match) @@ -58,10 +59,10 @@ (define (jsonish->upstream-source name jsonish) name "/" relative-url)))) '("tar.lz" "tar.xz" "tar.bz2" "tar.gz"))))))) -(define* (import-gnome-release package #:key (version #f)) +(define* (import-gnome-release package #:key version partial-version?) "Return the latest release of PACKAGE, a GNOME package, or #f if it could not be determined. Optionally include a VERSION string to fetch a specific -version." +version, which may be partial if PARTIAL-VERSION? is #t." (define %not-dot (char-set-complement (char-set #\.))) @@ -90,28 +91,6 @@ (define* (import-gnome-release package #:key (version #f)) ;; Some packages like "NetworkManager" have camel-case names. (package-upstream-name package)) - (define (find-latest-release releases) - (fold (match-lambda* - (((key . value) result) - (cond ((release-version? key) - (match result - (#f - (cons key value)) - ((newest . _) - (if (version>? key newest) - (cons key value) - result)))) - (else - result)))) - #f - releases)) - - (define (find-version-release releases version) - (find (match-lambda - ((key . value) - (string=? key version))) - releases)) - (guard (c ((http-get-error? c) (unless (= 404 (http-get-error-code c)) (warning (G_ "failed to download from '~a': ~a (~s)~%") @@ -135,11 +114,20 @@ (define* (import-gnome-release package #:key (version #f)) (match json (#(4 releases _ ...) (let* ((releases (assoc-ref releases upstream-name)) - (latest (if version - (find-version-release releases version) - (find-latest-release releases)))) - (and latest - (jsonish->upstream-source upstream-name latest)))))))) + (all-versions (map car releases)) + (release-versions (filter release-version? all-versions)) + (version (or (find-version release-versions + version partial-version?) + (and version + ;; If the user-provided VERSION could not be + ;; found, fallback to look through all + ;; versions. + (find-version all-versions + version partial-version?))))) + (and version + (jsonish->upstream-source + upstream-name + (find (compose (cut string=? version <>) car) releases))))))))) (define %gnome-updater (upstream-updater diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 422887d435..0186db014a 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -379,7 +379,7 @@ (define hackage-package? (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE." (let* ((hackage-name (package-upstream-name* package)) (cabal-meta (hackage-fetch hackage-name version))) diff --git a/guix/import/hexpm.scm b/guix/import/hexpm.scm index 71a54ba973..bbf980dab4 100644 --- a/guix/import/hexpm.scm +++ b/guix/import/hexpm.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2016 David Craven <david <at> craven.ch> ;;; Copyright © 2017, 2019-2021, 2024 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2019 Martin Becze <mjbecze <at> riseup.net> -;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> +;;; Copyright © 2019, 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; Copyright © 2020-2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. @@ -32,7 +32,7 @@ (define-module (guix import hexpm) call-with-temporary-output-file)) #:use-module (guix packages) #:use-module (guix upstream) - #:autoload (guix utils) (version>? file-sans-extension) + #:autoload (guix utils) (file-sans-extension version>? version-prefix?) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -95,7 +95,7 @@ (define-json-mapping <hexpm-version> make-hexpm-version hexpm-version? (define (lookup-hexpm name) - "Look up NAME on hex.pm and return the corresopnding <hexpm> record + "Look up NAME on hex.pm and return the corresponding <hexpm-pkgdef> record or #f if it was not found." (and=> (json-fetch (package-url name)) json->hexpm)) @@ -215,16 +215,11 @@ (define (strings->licenses strings) license))) strings)) -(define (hexpm-latest-release package) - "Return the version string for the latest stable release of PACKAGE." - ;; Use latest-stable if specified (see comment in hexpm-pkgdef above), - ;; otherwise compare the lists of release versions. - (let ((latest-stable (hexpm-latest-stable package))) - (if (not (unspecified? latest-stable)) - latest-stable - (let ((versions (map hexpm-version-number (hexpm-versions package)))) - (fold (lambda (a b) - (if (version>? a b) a b)) (car versions) versions))))) +(define (hexpm-releases package) + "Return the version strings for releases of PACKAGE, a <hexpm-pkgdef> +object, ordered from newest to oldest." + (sort (map hexpm-version-number (hexpm-versions package)) + version>?)) (define* (hexpm->guix-package package-name #:key version #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the @@ -238,7 +233,7 @@ (define* (hexpm->guix-package package-name #:key version #:allow-other-keys) (define version-number (and package (or version - (hexpm-latest-release package)))) + (first (hexpm-releases package))))) (define version* (and package @@ -320,17 +315,20 @@ (define* (hexpm-name->package-name name #:optional (language "erlang")) ;;; Updater ;;; -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE. Optionally -include a VERSION string to fetch a specific version." +include a VERSION string to fetch a specific version, which may be a version +prefix when PARTIAL-VERSION? is #t." (let* ((hexpm-name (guix-package->hexpm-name package)) (hexpm (lookup-hexpm hexpm-name)) - (version (or version (hexpm-latest-release hexpm))) - (url (hexpm-uri hexpm-name version))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list url))))) + (latest-stable (hexpm-latest-stable hexpm)) + (releases (hexpm-releases hexpm)) + (version (find-version releases version partial-version?))) + (and version + (upstream-source + (package (package-name package)) + (version version) + (urls (list (hexpm-uri hexpm-name version))))))) (define %hexpm-updater (upstream-updater diff --git a/guix/import/kde.scm b/guix/import/kde.scm index 0ae457ef3d..046bfc5a8e 100644 --- a/guix/import/kde.scm +++ b/guix/import/kde.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 David Craven <david <at> craven.ch> ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2019 Hartmut Goebel <h.goebel <at> crazy-compilers.com> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +20,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import kde) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (guix http-client) #:use-module (guix gnu-maintenance) #:use-module (guix packages) @@ -149,48 +151,39 @@ (define (uri->kde-path-pattern uri) (string-join (map version->pattern directory-parts) "/") "/")))) -(define* (import-kde-release package #:key (version #f)) +(define* (import-kde-release package #:key version partial-version?) "Return the latest release of PACKAGE, a KDE package, or #f if it could not be determined. Optionally include a VERSION string to fetch a specific -version." - - (define (find-latest-archive-version archives) - (fold (lambda (file1 file2) - (if (and file2 - (version>? (tarball-sans-extension (basename file2)) - (tarball-sans-extension (basename file1)))) - file2 - file1)) - #f - archives)) - +version, which may be a partial prefix when PARTIAL-VERSION? is #t." (let* ((uri (string->uri (origin-uri (package-source package)))) (path-rx (uri->kde-path-pattern uri)) (name (package-upstream-name package)) (files (download.kde.org-files)) - ;; select archives for this package + ;; Select archives for this package. (relevant (filter (lambda (file) (and (regexp-exec path-rx file) (release-file? name (basename file)))) files)) - ;; Find latest version. - (version (or version - (and (not (null? relevant)) - (tarball->version (find-latest-archive-version relevant))))) - ;; Find archives matching this version. - (tarballs (filter (lambda (file) - (string=? version (tarball->version file))) - relevant))) - (match tarballs - (() #f) - (_ - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://kde/" file)) - tarballs))))))) - + ;; Build an association list of file names keyed by their version. + (all-tarballs (map (lambda (x) + (cons (tarball->version x) x)) + relevant)) + (versions (map car all-tarballs)) + ;; Find the latest version. + (version (find-version versions version partial-version?)) + ;; Find all archives matching this version. + (tarballs (and version + (map cdr (filter (match-lambda + ((x . file-name) + (string=? version x))) + all-tarballs))))) + (and version tarballs + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs)))))) (define %kde-updater (upstream-updater diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm index 01953ea69c..75b474ead7 100644 --- a/guix/import/launchpad.scm +++ b/guix/import/launchpad.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Matthew James Kraai <kraai <at> ftbfs.org> ;;; Copyright © 2020 Brice Waegeneire <brice <at> waegenei.re> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,9 +27,10 @@ (define-module (guix import launchpad) #:use-module (web uri) #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module (guix utils) + #:use-module ((guix utils) #:select (version-major+minor)) #:export (%launchpad-updater)) (define (find-extension url) @@ -103,9 +105,9 @@ (define (launchpad-repository url) (match (string-split (uri-path (string->uri url)) #\/) ((_ repo . rest) repo))) -(define (latest-released-version repository) - "Return a string of the newest released version name given the REPOSITORY, -for example, 'linuxdcpp'. Return #f if there is no releases." +(define (release-versions repository) + "Return a list of the release version strings available for REPOSITORY, a +repository name such as 'linuxdcpp'." (define (pre-release? x) ;; Versions containing anything other than digit characters and "." (for ;; example, "5.1.0-rc1") are assumed to be pre-releases. @@ -116,31 +118,31 @@ (define (latest-released-version repository) (match (json-fetch (string-append "https://api.launchpad.net/1.0/" repository "/releases")) - (#f #f) ;404 or similar + (#f #f) ;404 or similar (json - (assoc-ref - (last (remove pre-release? (vector->list (assoc-ref json "entries")))) - "version")))) + (let ((releases (remove pre-release? + (vector->list (assoc-ref json "entries"))))) + (map (cut assoc-ref <> "version") releases))))) -(define* (import-release pkg #:key (version #f)) +(define* (import-release pkg #:key version partial-version?) "Return an <upstream-source> for the latest release of PKG. Optionally -include a VERSION string to fetch a specific version." +include a VERSION string to fetch a specific version. When PARTIAL-VERSION? +is #t, update to the latest version prefixed by VERSION." (define (origin-launchpad-uri origin) (match (origin-uri origin) - ((? string? url) url) ; surely a Launchpad URL + ((? string? url) url) ;surely a Launchpad URL ((urls ...) (find (cut string-contains <> "launchpad.net") urls)))) (let* ((source-uri (origin-launchpad-uri (package-source pkg))) (name (package-name pkg)) - (repository (launchpad-repository source-uri)) - (newest-version (or version (latest-released-version repository)))) - (if newest-version + (versions (release-versions (launchpad-repository source-uri))) + (version (find-version versions version partial-version?))) + (and version (upstream-source (package name) - (version newest-version) - (urls (list (updated-launchpad-url pkg newest-version)))) - #f))) ; On Launchpad but no proper releases + (version version) + (urls (list (updated-launchpad-url pkg version))))))) (define %launchpad-updater (upstream-updater diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index 5ea6e023ce..a46296cdc4 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -483,7 +483,7 @@ (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 #:key (version #f)) +(define* (latest-minetest-release pkg #:key version partial-version?) "Return an <upstream-source> for the latest release of the package PKG, or #false if the latest release couldn't be determined." (define author/name diff --git a/guix/import/opam.scm b/guix/import/opam.scm index a7f8092507..4b69d50ceb 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -417,7 +417,7 @@ (define (opam-package? package) (member (build-system-name (package-build-system package)) '(dune ocaml)) (not (string-prefix? "ocaml4" (package-name package))))) -(define* (latest-release package #:key (version #f)) +(define* (latest-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE." (when version (raise diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 4af02dd250..9a40dea1c1 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -35,6 +35,7 @@ (define-module (guix import pypi) #:use-module (ice-9 regex) #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -522,11 +523,17 @@ (define (find-project-url name pypi-url) a substring of the PyPI URI that identifies the package.") pypi-url name)) name))) -(define* (pypi-package->upstream-source pypi-package #:optional version) +(define* (pypi-package->upstream-source pypi-package + #:optional version partial-version?) "Return the upstream source for the given VERSION of PYPI-PACKAGE, a -<pypi-project> record. If VERSION is omitted or #f, use the latest version." +<pypi-project> record. If VERSION is omitted or #f, use the latest version. +If PARTIAL-VERSION? is #t, use the latest version found that is prefixed by +VERSION." (let* ((info (pypi-project-info pypi-package)) - (version (or version (project-info-version info))) + (versions (map (match-lambda + ((version . _) version)) + (pypi-project-releases pypi-package))) + (version (find-version versions version partial-version?)) (dist (source-release pypi-package version)) (source-url (distribution-url dist)) (wheel-url (and=> (wheel-release pypi-package version) @@ -661,14 +668,14 @@ (define pypi-package? (string-prefix? "https://pypi.org/packages" url) (string-prefix? "https://files.pythonhosted.org/packages" url))))) -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE. Optionally include a VERSION string to fetch a specific version." - (let* ((pypi-name (guix-package->pypi-name package)) - (pypi-package (pypi-fetch pypi-name))) - (and pypi-package - (guard (c ((missing-source-error? c) #f)) - (pypi-package->upstream-source pypi-package version))))) + (and-let* ((pypi-name (guix-package->pypi-name package)) + (pypi-package (pypi-fetch pypi-name))) + (guard (c ((missing-source-error? c) #f)) + (pypi-package->upstream-source pypi-package + version partial-version?)))) (define %pypi-updater (upstream-updater diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 9554c3d7a4..84aba8aead 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -142,7 +142,7 @@ (define latest-lts-release (mlambda () (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))))) - (lambda* (pkg #:key (version #f)) + (lambda* (pkg #:key version partial-version?) "Return an <upstream-source> for the latest Stackage LTS release of PACKAGE or #f if the package is not included in the Stackage LTS release." (when version diff --git a/guix/import/test.scm b/guix/import/test.scm index 4bd356bddc..7414cf5253 100644 --- a/guix/import/test.scm +++ b/guix/import/test.scm @@ -18,6 +18,8 @@ (define-module (guix import test) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix utils) #:select (version-prefix?)) @@ -76,18 +78,17 @@ (define (test-package? package) (and (not (vlist-null? (test-target-version))) ;cheap test (pair? (available-updates package)))) -(define* (import-release package #:key (version #f)) +(define* (import-release package #:key version partial-version?) "Return the <upstream-source> record denoting either the latest version of PACKAGE or VERSION." (match (available-updates package) (() #f) ((sources ...) - (if version - (find (lambda (source) - (string=? (upstream-source-version source) - version)) - sources) - (first sources))))) + (let* ((versions (map upstream-source-version sources)) + (version (find-version versions version partial-version?))) + (and version + (find (compose (cut string=? version <>) upstream-source-version) + sources)))))) (define %test-updater (upstream-updater diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index c11016853a..bac6a88168 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado <at> elephly.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> +;;; Copyright © 2021, 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; Copyright © 2024 Nicolas Goaziou <mail <at> nicolasgoaziou.fr> ;;; ;;; This file is part of GNU Guix. @@ -35,7 +35,8 @@ (define-module (guix import texlive) #:use-module (guix store) #:use-module (guix svn-download) #:use-module (guix upstream) - #:use-module ((guix utils) #:select (downstream-package-name)) + #:use-module ((guix utils) #:select (downstream-package-name + version>? version-prefix?)) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 popen) @@ -261,17 +262,21 @@ (define (current-day) "Return number of days since Epoch." (floor (/ (time-second (current-time)) (* 24 60 60)))) -(define latest-texlive-tag - ;; Return the latest TeX Live tag in repository. The argument refers to - ;; current day, so memoization is only active a single day, as the - ;; repository may have been updated between two calls. +(define texlive-tags (memoize (lambda* (#:key (day (current-day))) - (let ((output - (svn-command "ls" (string-append %texlive-repository "tags") "-v"))) - ;; E.g. "70951 karl april 15 18:11 texlive-2024.2/\n\n" - (and=> (string-match "texlive-([^/]+)/\n*$" output) - (cut match:substring <> 1)))))) + "Return all tags found in for the TeX Live tags in repository, from +latest to oldest. The argument refers to current day, so memoization is only +active a single day, as the repository may have been updated between two +calls." + (let* ((output (svn-command + "ls" (string-append %texlive-repository "tags") "-v")) + (lines (string-split output #\newline))) + ;; Each line look like "70951 karl april 15 18:11 texlive-2024.2/\n\n". + (filter-map (lambda (l) + (and=> (string-match "texlive-([^/]+)/\n*$" l) + (cut match:substring <> 1))) + lines))))) (define string->license (match-lambda @@ -761,7 +766,7 @@ (define texlive->guix-package version whenever VERSION keyword is specified. Otherwise, grab package latest release. When DATABASE is provided, fetch metadata from there, ignoring VERSION." - (let ((version (or version (latest-texlive-tag)))) + (let ((version (or version (first (texlive-tags))))) (tlpdb->package name version (or database (tlpdb/cached version)))))) (define* (texlive-recursive-import name #:key repo version) @@ -785,13 +790,14 @@ (define (package-from-texlive-repository? package) (eq? 'texlive (build-system-name (package-build-system package))))))) -(define* (latest-release package #:key version) +(define* (latest-release package #:key version partial-version?) "Return an <upstream-source> for the latest release of PACKAGE. Optionally -include a VERSION string to fetch a specific version." - (let* ((version (or version (latest-texlive-tag))) +include a VERSION string to fetch a specific version, which may be a partial +prefix when PARTIAL-VERSION? is #t." + (let* ((version (find-version (texlive-tags) version partial-version?)) (database (tlpdb/cached version)) (upstream-name (package-upstream-name* package))) - (and (assoc-ref database upstream-name) + (and version (assoc-ref database upstream-name) (upstream-source (package upstream-name) (version version) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 6f5efa790e..d7ba13a69a 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2019 Robert Vollmert <rob <at> vllmrt.net> ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix <at> googlemail.com> ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> +;;; Copyright © 2021, 2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev> ;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz> ;;; Copyright © 2022 Alice Brenon <alice.brenon <at> ens-lyon.fr> @@ -85,6 +85,8 @@ (define-module (guix import utils) guix-name + find-version + recursive-import)) (define (factorize-uri uri version) @@ -615,6 +617,22 @@ (define* (chunk-lines lines #:optional (pred string-null?)) (define-deprecated/alias guix-name downstream-package-name) +(define* (find-version versions #:optional version partial?) + "Find VERSION amongst VERSIONS. When VERSION is not provided, return the +latest version. When PARTIAL? is #t, VERSION is treated as a version prefix; +e.g. finding version \"0.1\" may return \"0.1.8\" if it is the newest \"0.1\" +prefixed version found in VERSIONS. Return #f when VERSION could not be +found." + (let ((versions (sort versions version>?))) + (cond + ((and version partial?) ;partial version + (find (cut version-prefix? version <>) versions)) + ((and version (not partial?)) ;exact version + (find (cut string=? version <>) versions)) + ((not (null? versions)) ;latest version + (first versions)) + (else #f)))) ;should not happen + (define (topological-sort nodes node-dependencies node-name) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 8c72d0c545..59e8838e14 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -10,7 +10,7 @@ ;;; Copyright © 2020 Simon Tournier <zimon.toutoune <at> gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev> ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com> -;;; Copyright © 2023 Maxim Cournoyer maxim.cournoyer <at> gmail.com> +;;; Copyright © 2023, 2024 Maxim Cournoyer maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -170,7 +170,9 @@ (define (show-help) -m, --manifest=FILE select all the packages from the manifest in FILE")) (display (G_ " --target-version=VERSION - update the package or packages to VERSION")) + update the package or packages to VERSION + VERSION may be partially specified, e.g. as 6 + or 6.4 instead of 6.4.3")) (display (G_ " -t, --type=UPDATER,... restrict to updates from the specified updaters (e.g., 'gnu')")) @@ -212,20 +214,22 @@ (define (show-help) ;;; (define-record-type <update-spec> - (%update-spec package version) + (%update-spec package version partial?) update? (package update-spec-package) - (version update-spec-version)) + (version update-spec-version) + (partial? update-spec-partial?)) -(define* (update-spec package #:optional version) - (%update-spec package version)) +(define* (update-spec package #:optional version partial?) + (%update-spec package version partial?)) (define (update-specification->update-spec spec fallback-version) "Given SPEC, a package name like \"guile <at> 2.0=2.0.8\", return a <update> record with two fields: the package to upgrade, and the target version. When SPEC lacks a version, use FALLBACK-VERSION." (match (string-rindex spec #\=) - (#f (update-spec (specification->package spec) fallback-version)) + (#f (update-spec (specification->package spec) fallback-version + (not (not fallback-version)))) (idx (update-spec (specification->package (substring spec 0 idx)) (substring spec (1+ idx)))))) @@ -281,9 +285,9 @@ (define (options->update-specs opts) spec target-version))) (('expression . exp) (list (update-spec (read/eval-package-expression exp) - target-version))) + target-version #t))) (('manifest . manifest) - (map (cut update-spec <> target-version) + (map (cut update-spec <> target-version #t) (packages-from-manifest manifest))) (_ '())) @@ -363,92 +367,96 @@ (define (warn-no-updater package) (G_ "no updater for ~a~%") (package-name package))) -(define* (update-package store package version updaters +(define* (update-package store update-spec updaters #:key (key-download 'interactive) key-server warn?) - "Update the source file that defines PACKAGE with the new version. -KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'interactive' (default), 'always', and 'never'. When WARN? is true, -warn about packages that have no matching updater." - (if (lookup-updater package updaters) - (let ((version output source - (package-update store package updaters - #:version version - #:key-download key-download - #:key-server key-server)) - (loc (or (package-field-location package 'version) - (package-location package)))) - (when version - (if (and=> output file-exists?) - (begin - (info loc - (G_ "~a: updating from version ~a to version ~a...~%") - (package-name package) - (package-version package) version) - (let ((hash (file-hash* output))) - (update-package-source package source hash))) - (warning (G_ "~a: version ~a could not be \ + "Update the source file that correspond to the package in UPDATE-SPEC, +an <update-spec> object. KEY-DOWNLOAD specifies a download policy for missing +OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. +When WARN? is true, warn about packages that have no matching updater. +PARTIAL-VERSION? is provided to the underlying `package-update' call; see its +documentation for the details." + (match update-spec + (($ <update-spec> package version partial?) + (if (lookup-updater package updaters) + (let ((version output source + (package-update store package updaters + #:version version + #:partial-version? partial? + #:key-download key-download + #:key-server key-server)) + (loc (or (package-field-location package 'version) + (package-location package)))) + (when version + (if (and=> output file-exists?) + (begin + (info loc + (G_ "~a: updating from version ~a to version ~a...~%") + (package-name package) + (package-version package) version) + (let ((hash (file-hash* output))) + (update-package-source package source hash))) + (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") - (package-name package) version)))) - (when warn? - (warn-no-updater package)))) + (package-name package) version)))) + (when warn? + (warn-no-updater package)))))) (define* (check-for-package-update update-spec updaters #:key warn?) "Check whether UPDATE-SPEC is feasible, and print a message. When WARN? is true and no updater exists for PACKAGE, print a warning." - (define package - (update-spec-package update-spec)) - - (match (package-latest-release package updaters - #:version - (update-spec-version update-spec)) - ((? upstream-source? source) - (let ((loc (or (package-field-location package 'version) - (package-location package)))) - (case (version-compare (upstream-source-version source) - (package-version package)) - ((>) - (info loc - (G_ "~a would be upgraded from ~a to ~a~%") - (package-name package) (package-version package) - (upstream-source-version source))) - ((=) - (when warn? - (info loc - (G_ "~a is already the latest version of ~a~%") - (package-version package) - (package-name package)))) - (else - (if (update-spec-version update-spec) - (info loc - (G_ "~a would be downgraded from ~a to ~a~%") - (package-name package) - (package-version package) - (upstream-source-version source)) - (when warn? - (warning loc - (G_ "~a is greater than \ + (match update-spec + (($ <update-spec> package version partial?) + (match (package-latest-release package updaters + #:version version + #:partial-version? partial?) + ((? upstream-source? source) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (case (version-compare (upstream-source-version source) + (package-version package)) + ((>) + (info loc + (G_ "~a would be upgraded from ~a to ~a~%") + (package-name package) (package-version package) + (upstream-source-version source))) + ((=) + (when warn? + (info loc + (G_ "~a is already the latest version of ~a~%") + (package-version package) + (package-name package)))) + (else + (if version + (info loc + (G_ "~a would be downgraded from ~a to ~a~%") + (package-name package) + (package-version package) + (upstream-source-version source)) + (when warn? + (warning loc + (G_ "~a is greater than \ the latest known version of ~a (~a)~%") - (package-version package) - (package-name package) - (upstream-source-version source)))))))) - (#f - (when warn? - ;; Distinguish between "no updater" and "failing updater." - (match (lookup-updater package updaters) - ((? upstream-updater? updater) - (if (update-spec-version update-spec) - (warning (G_ "'~a' updater failed to find version ~a of '~a'~%") - (upstream-updater-name updater) - (update-spec-version update-spec) - (package-name package)) - (warning (package-location package) - (G_ "'~a' updater failed to determine available \ + (package-version package) + (package-name package) + (upstream-source-version source)))))))) + (#f + (when warn? + ;; Distinguish between "no updater" and "failing updater." + (match (lookup-updater package updaters) + ((? upstream-updater? updater) + (if version + (warning (G_ "'~a' updater failed to find version ~a of '~a'~%") + (upstream-updater-name updater) + version + (package-name package)) + (warning (package-location package) + (G_ "'~a' updater failed to determine available \ releases for ~a~%") - (upstream-updater-name updater) - (package-name package)))) - (#f - (warn-no-updater package))))))) + (upstream-updater-name updater) + (package-name package)))) + (#f + (warn-no-updater package))))))))) ;;; @@ -633,10 +641,9 @@ (define-command (guix-refresh . args) (compose location-line spec->location))))) (for-each - (lambda (update) + (lambda (spec) (update-package store - (update-spec-package update) - (update-spec-version update) + spec updaters #:key-server (%openpgp-key-server) #:key-download key-download diff --git a/guix/upstream.scm b/guix/upstream.scm index 62ba6c9d39..8dd8d6c803 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -263,16 +263,17 @@ (define* (lookup-updater package (define* (package-latest-release package #:optional (updaters (force %updaters)) - #:key (version #f)) - "Return an upstream source to update PACKAGE, a <package> object, or #f if -none of UPDATERS matches PACKAGE. When several updaters match PACKAGE, try -them until one of them returns an upstream source. It is the caller's -responsibility to ensure that the returned source is newer than the current -one." + #:key version partial-version?) + "Return an <upstream-source> object to update PACKAGE, a <package> object, +or #f if none of UPDATERS matches PACKAGE. When several updaters match +PACKAGE, try them until one of them returns an upstream source. It is the +caller's responsibility to ensure that the returned source is newer than the +current one." (any (match-lambda (($ <upstream-updater> name description pred import) (and (pred package) - (import package #:version version)))) + (import package #:version version + #:partial-version? partial-version?)))) updaters)) (define* (package-latest-release* package @@ -511,7 +512,7 @@ (define %method-updates (define* (package-update store package #:optional (updaters (force %updaters)) - #:key (version #f) + #:key version partial-version? (key-download 'interactive) key-server) "Return the new version, the file name of the new version tarball, and input changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date; @@ -520,8 +521,13 @@ (define* (package-update store package values: 'always', 'never', and 'interactive' (default). When VERSION is specified, update PACKAGE to that version, even if that is a -downgrade." - (match (package-latest-release package updaters #:version version) +downgrade. When PARTIAL-VERSION? is true, treat VERSION as having been only +partially specified, in which case the package will be updated to the newest +compatible version if there are no exact match for VERSION. For example, +providing \"46\" as the version may update the package to version \"46.6.4\"." + (match (package-latest-release package updaters + #:version version + #:partial-version? partial-version?) ((? upstream-source? source) (if (or (version>? (upstream-source-version source) (package-version package)) diff --git a/tests/gem.scm b/tests/gem.scm index dae29437e5..beee150875 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -49,6 +49,25 @@ (define test-foo-json \"licenses\": [\"MIT\", \"Apache 2.0\"] }") +(define test-foo-versions-json + "[{\"authors\": \" Maxim \", + \"built_at\": \"2012-10-24T00:00:00.000Z\", + \"created_at\": \"2012-11-03T07:41:49.007Z\", + \"description\": \"test gem\", + \"downloads_count\" :9195, + \"metadata\": {\"homepage_uri\":\"\"}, + \"number\": \"1.0.0\", + \"summary\": \"foo!!!\", + \"platform\": \"ruby\", + \"rubygems_version\": \"\u003e= 0\", + \"ruby_version\": null, + \"priceless\": false, + \"licenses\": null, + \"requirements\": null, + \"sha\": \"523009a5b977f79c8eaa79b521e416f26482bc4fbbcc04bd08580696e303a715\", + \"spec_sha\": \"c7cf42bac0d01eb12b68294d1cdb4e20e7cb222ca958ad70ed1e9a686b551819\" +}]") + (define test-foo-v2-json "{ \"name\": \"foo\", @@ -273,6 +292,9 @@ (define test-bundler-json ("https://rubygems.org/api/v1/gems/foo.json" (values (open-input-string test-foo-json) (string-length test-foo-json))) + ("https://rubygems.org/api/v1/versions/foo.json" + (values (open-input-string test-foo-versions-json) + (string-length test-foo-versions-json))) (_ (error "Unexpected URL: " url))))) (let ((source (package-latest-release (dummy-package "ruby-foo" diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 6fde1eb8b1..82a02bec6f 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2021 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be> +;;; Copyright © 2023-2024 Maxim Cournoyer <maxim.cournoyer <at> gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ (define-module (test-gnu-maintenance) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module ((web client) #:select (current-http-proxy)) + #:use-module ((web uri) #:select (uri? uri->string)) #:use-module (ice-9 match)) (test-begin "gnu-maintenance") @@ -157,11 +159,17 @@ (define-module (test-gnu-maintenance) (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2")) -(test-equal "rewrite-url, without to-version" - "http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz" - (with-http-server - ;; First reply, crawling http://dist.libuv.example.org/dist/. - `((200 "\ +(define (mock-http-fetch/cached testcase) + (lambda (url . rest) + (let* ((url (if (uri? url) + (uri->string url) + url)) + (body (assoc-ref testcase url))) + (if body + (open-input-string body) + (error "mocked http-fetch Unexpected URL: " url))))) + +(define libuv-dist-html "\ <!DOCTYPE html> <html> <head><title>Index of dist</title></head> @@ -174,8 +182,8 @@ (define-module (test-gnu-maintenance) <a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a> </body> </html>") - ;; Second reply, crawling http://dist.libuv.example.org/dist/v1.46.0/. - (200 "\ + +(define libuv-dist-1.46.0-html "\ <!DOCTYPE html> <html> <head><title>Index of dist/v1.46.0</title></head> @@ -190,9 +198,44 @@ (define-module (test-gnu-maintenance) <a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\"> libuv-v1.46.0.tar.gz.sign</a> </body> -</html>")) - (parameterize ((current-http-proxy (%local-url))) - (rewrite-url "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" - "1.45.0")))) +</html>") + +(define libuv-dist-1.44.2-html "\ +<!DOCTYPE html> +<html> +<head><title>Index of dist/v1.44.2</title></head> +<body> +<a href=\"../\">../</a> +<a href=\"libuv-v1.44.2-dist.tar.gz\" title=\"libuv-v1.44.2-dist.tar.gz\"> + libuv-v1.44.2-dist.tar.gz</a> +<a href=\"libuv-v1.44.2-dist.tar.gz.sign\" title=\"libuv-v1.44.2-dist.tar.gz.sign\"> + libuv-v1.44.2-dist.tar.gz.sign</a> +<a href=\"libuv-v1.44.2.tar.gz\" title=\"libuv-v1.44.2.tar.gz\"> + libuv-v1.44.2.tar.gz</a> +<a href=\"libuv-v1.44.2.tar.gz.sign\" title=\"libuv-v1.44.2.tar.gz.sign\"> + libuv-v1.44.2.tar.gz.sign</a> +</body> +</html>") + +(define libuv-html-data + `(("http://dist.libuv.example.org/dist" . ,libuv-dist-html) + ("http://dist.libuv.example.org/dist/v1.44.2" . ,libuv-dist-1.44.2-html) + ("http://dist.libuv.example.org/dist/v1.46.0" . ,libuv-dist-1.46.0-html))) + +(test-equal "rewrite-url, without to-version" + "http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz" + (mock ((guix http-client) http-fetch/cached + (mock-http-fetch/cached libuv-html-data)) + (rewrite-url + "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" + "1.45.0"))) + +(test-equal "rewrite-url, partial to-version" + "http://dist.libuv.example.org/dist/v1.44.2/libuv-v1.44.2.tar.gz" + (mock ((guix http-client) http-fetch/cached + (mock-http-fetch/cached libuv-html-data)) + (rewrite-url + "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" + "1.45.0" #:to-version "1.44" #:partial-version? #t))) (test-end) diff --git a/tests/guix-refresh.sh b/tests/guix-refresh.sh index 2ce3c592ab..b5b38189cb 100644 --- a/tests/guix-refresh.sh +++ b/tests/guix-refresh.sh @@ -31,7 +31,8 @@ export GUIX_TEST_UPDATER_TARGETS idutils_version="$(guix package -A ^idutils$ | cut -f2)" GUIX_TEST_UPDATER_TARGETS=' (("guile" "3" (("12.5" "file:///dev/null") - ("1.6.4" "file:///dev/null"))) + ("1.6.4" "file:///dev/null") + ("3.13.3" "file:///dev/null"))) ("libreoffice" "" (("1.0" "file:///dev/null"))) ("idutils" "" (("'$idutils_version'" "file:///dev/null"))) ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source" @@ -116,6 +117,13 @@ case "$(guix refresh -t test guile --target-version=2.0.0 2>&1)" in *) false;; esac +# Partial target version => select the newest release prefixed by it. +guix refresh -t test guile --target-version=3 # XXX: should return non-zero? +case "$(guix refresh -t test guile --target-version=3 2>&1)" in + *"would be upgraded"*"3.13.3"*) true;; + *) false;; +esac + for spec in "guile=1.6.4" "guile <at> 3=1.6.4" do guix refresh -t test "$spec" diff --git a/tests/import-git.scm b/tests/import-git.scm index 6dd8ad1649..a532070a8d 100644 --- a/tests/import-git.scm +++ b/tests/import-git.scm @@ -22,6 +22,7 @@ (define-module (test-import-git) #:use-module (guix tests) #:use-module (guix packages) #:use-module (guix import git) + #:use-module ((guix import utils) #:select (find-version)) #:use-module (guix git-download) #:use-module (guix tests git) #:use-module (srfi srfi-1) @@ -45,6 +46,9 @@ (define* (make-package directory version #:optional (properties '())) (base32 "0000000000000000000000000000000000000000000000000000")))))) +(define (latest-git-tag-version package) + (find-version (map car ((@@ (guix import git) get-package-tags) package)))) + (test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter" "1.0.1" (with-temporary-git-repository directory base-commit: be058cf6fcf01be49e98b8a646e1ffdb34130db6 -- 2.47.1

This bug report was last modified 86 days ago.

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.

GNU bug report logs - #75871 [PATCH 0/1] Partial version support for 'guix refresh --target-version'.

GNU bug report logs - #75871
[PATCH 0/1] Partial version support for 'guix refresh --target-version'.