mirror/guix
mirror/guix
1
Fork 0
mirror of https://https.git.savannah.gnu.org/git/guix.git/ synced 2025-07-10 16:50:43 +02:00
Code Releases Activity

refresh: Add support for partial target versions.

Browse source 
* 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.

Series-to: 75871@debbugs.gnu.org
Change-Id: I092a58b57ac42e54a2fa55e7761e8c6993af8ad4
This commit is contained in:
Maxim Cournoyer 2024-11-13 14:21:16 +09:00
parent 79a46d6537
commit f13f076968
No known key found for this signature in database
GPG key ID: 1260E46482E63562
29 changed files with 627 additions and 500 deletions
Download patch file Download diff file Expand all files Collapse all files

12
doc/guix.texi
View file

@ -14975,6 +14975,7 @@ gnu/packages/guile.scm:147:2: guile: updating from version 2.0.10 to version 2.0
@dots{} @dots{}
@end example @end example
@cindex target version, guix refresh
In some specific cases, you may have many packages specified via a In some specific cases, you may have many packages specified via a
manifest or a module selection which should all be updated together; for manifest or a module selection which should all be updated together; for
these cases, the @option{--target-version} option can be provided to have these cases, the @option{--target-version} option can be provided to have
@ -14995,6 +14996,17 @@ gnu/packages/qt.scm:2070:13: qtquickcontrols2 would be upgraded from 5.15.8 to 5
@dots{} @dots{}
@end example @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, Sometimes the upstream name differs from the package name used in Guix,
and @command{guix refresh} needs a little help. Most updaters honor the and @command{guix refresh} needs a little help. Most updaters honor the
@code{upstream-name} property in package definitions, which can be used @code{upstream-name} property in package definitions, which can be used

118
guix/gnu-maintenance.scm
View file

@ -3,7 +3,7 @@
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2023, 2025 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -44,7 +44,7 @@
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix packages) #: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 (zlib) (call-with-gzip-input-port)
#:autoload (htmlprag) (html->sxml) ;from Guile-Lib #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
#:export (gnu-package-name #:export (gnu-package-name
@ -346,12 +346,15 @@ name/directory pairs."
(define* (import-ftp-release project (define* (import-ftp-release project
#:key #:key
(version #f) version
partial-version?
(server "ftp.gnu.org") (server "ftp.gnu.org")
(directory (string-append "/gnu/" project)) (directory (string-append "/gnu/" project))
(file->signature (cut string-append <> ".sig"))) (file->signature (cut string-append <> ".sig")))
"Return an <upstream-source> for the latest release of PROJECT on SERVER "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 Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be
useful to reuse connections. useful to reuse connections.
@ -417,7 +420,9 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(and (release-file? project file) (and (release-file? project file)
(file->source directory file))) (file->source directory file)))
(_ #f)) (_ #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 ;; Assume that SUBDIRS correspond to versions, and jump into the
;; one with the highest version number. ;; one with the highest version number.
@ -440,14 +445,17 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(define* (import-release package (define* (import-release package
#:key #:key
(version #f) version
partial-version?
(server "ftp.gnu.org") (server "ftp.gnu.org")
(directory (string-append "/gnu/" package))) (directory (string-append "/gnu/" package)))
"Return the <upstream-source> for the latest version of PACKAGE or #f. "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 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 (import-ftp-release package
#:version version #:version version
#:partial-version? partial-version?
#:server server #:server server
#:directory directory)) #:directory directory))
@ -463,7 +471,7 @@ of EXP otherwise."
(close-port port)) (close-port port))
#f))) #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 "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 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 hosted on ftp.gnu.org, or not under that name (this is the case for
@ -474,6 +482,7 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
(false-if-ftp-error (false-if-ftp-error
(import-release (package-upstream-name package) (import-release (package-upstream-name package)
#:version version #:version version
#:partial-version? partial-version?
#:server server #:server server
#:directory directory))))) #:directory directory)))))
@ -561,16 +570,23 @@ URL is a directory instead of a file, it should be suffixed with a slash (/)."
;;; TODO: Extend to support the RPM and GNOME version schemes? ;;; TODO: Extend to support the RPM and GNOME version schemes?
(define %version-rx "[0-9.]+") (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 "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 VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
by crawling the corresponding URL directories. Alternatively, when TO-VERSION 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 For example, the URL
\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be \"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
rewritten to something like 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 ;; XXX: major-minor may be #f if version is not a triplet but a single
;; number such as "2". ;; number such as "2".
(let* ((major-minor (false-if-exception (version-major+minor version))) (let* ((major-minor (false-if-exception (version-major+minor version)))
@ -590,14 +606,15 @@ rewritten to something like
(reverse (reverse
(fold (fold
(lambda (s parents) (lambda (s parents)
(if to-version (if (and to-version (not partial-version?))
;; Direct rewrite case; the archive is assumed to exist. ;; Direct rewrite case; the archive is assumed to exist.
(let ((u (string-replace-substring s version to-version))) (let ((u (string-replace-substring s version to-version)))
(cons (if (and major-minor to-major-minor) (cons (if (and major-minor to-major-minor)
(string-replace-substring u major-minor to-major-minor) (string-replace-substring u major-minor to-major-minor)
u) u)
parents)) 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 (let* ((pattern (if major-minor
(format #f "(~a|~a)" version major-minor) (format #f "(~a|~a)" version major-minor)
(format #f "(~a)" version))) (format #f "(~a)" version)))
@ -620,15 +637,14 @@ rewritten to something like
(m (string-match pattern l)) (m (string-match pattern l))
(v (match:substring m 1))) (v (match:substring m 1)))
(cons v l))) (cons v l)))
links))) links))
;; Retrieve the item having the largest version. (versions (map car candidates))
(if (null? candidates) (version (find-version versions to-version
parents partial-version?)))
(cons (cdr (first (sort candidates ;; Retrieve the item having the greatest version.
(lambda (x y) (if version
(version>? (car x) (cons (assoc-ref candidates version) parents)
(car y)))))) parents)) ;XXX: bogus case; throw an error?
parents)))
;; No version found in path component; continue. ;; No version found in path component; continue.
(cons s parents))))) (cons s parents)))))
(reverse url-prefix-components) (reverse url-prefix-components)
@ -639,12 +655,14 @@ rewritten to something like
#:key #:key
rewrite-url? rewrite-url?
version version
partial-version?
(directory (string-append (directory (string-append
"/" (package-upstream-name package))) "/" (package-upstream-name package)))
file->signature) file->signature)
"Return an <upstream-source> for the latest release of PACKAGE under "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 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 BASE-URL should be the URL of an HTML page, typically a directory listing as
found on 'https://kernel.org/pub'. found on 'https://kernel.org/pub'.
@ -663,7 +681,8 @@ also updated to the latest version, as explained in the doc of the
base-url base-url
(string-append base-url directory "/"))) (string-append base-url directory "/")))
(url (if rewrite-url? (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)) url))
(links (map (cut canonicalize-url <> url) (url->links url)))) (links (map (cut canonicalize-url <> url) (url->links url))))
@ -695,23 +714,18 @@ else #f. URL is assumed to fully specified."
(lambda (url) (list (uri-mirror-rewrite url)))))))))) (lambda (url) (list (uri-mirror-rewrite url))))))))))
(define candidates (define candidates
(filter-map url->release links)) (coalesce-sources (filter-map url->release links)))
(match candidates (define versions
(() #f) (map upstream-source-version candidates))
((first . _)
(if version (define new-version
;; Find matching release version and return it. (find-version versions version partial-version?))
(find (lambda (upstream)
(string=? (upstream-source-version upstream) version)) (and new-version
(coalesce-sources candidates)) (find (compose (cut string=? new-version <>)
;; Select the most recent release and return it. upstream-source-version)
(reduce (lambda (r1 r2) candidates))))
(if (version>? (upstream-source-version r1)
(upstream-source-version r2))
r1 r2))
first
(coalesce-sources candidates)))))))
;;; ;;;
@ -743,7 +757,7 @@ else #f. URL is assumed to fully specified."
(call-with-gzip-input-port port (call-with-gzip-input-port port
(compose string->lines get-string-all)))))) (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 "Return the latest release of PACKAGE, a GNU package available via
ftp.gnu.org. Optionally include a VERSION string to fetch a specific version. ftp.gnu.org. Optionally include a VERSION string to fetch a specific version.
@ -776,12 +790,15 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(string-contains file directory) (string-contains file directory)
(release-file? name (basename file)))) (release-file? name (basename file))))
files)) files))
;; find latest version (versions (delay (sort (delete-duplicates
(version (or version (map tarball->version relevant))
(and (not (null? relevant)) version>?)))
(tarball->version (version (or (and version partial-version?
(find-latest-tarball-version relevant))))) (find (cut version-prefix? version <>)
;; find tarballs matching this version (force versions)))
version
(first (force versions))))
;; Find tarballs matching this version.
(tarballs (filter (lambda (file) (tarballs (filter (lambda (file)
(string=? version (tarball->version file))) (string=? version (tarball->version file)))
relevant))) relevant)))
@ -998,11 +1015,11 @@ updater."
(or (assoc-ref (package-properties package) 'release-monitoring-url) (or (assoc-ref (package-properties package) 'release-monitoring-url)
((url-predicate http-url?) package))) ((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 "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 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) (define (expand-uri uri)
(match uri (match uri
((and (? string?) (? (cut string-prefix? "mirror://" <>) url)) ((and (? string?) (? (cut string-prefix? "mirror://" <>) url))
@ -1029,6 +1046,7 @@ VERSION string to fetch a specific version."
(import-html-release base package (import-html-release base package
#:rewrite-url? #t #:rewrite-url? #t
#:version version #:version version
#:partial-version? partial-version?
#:directory directory)))) #:directory directory))))
(define %gnu-updater (define %gnu-updater

59
guix/import/composer.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -36,6 +37,7 @@
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (composer->guix-package #:export (composer->guix-package
@ -58,10 +60,6 @@
(substring version 1)) (substring version 1))
(else version))) (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) (define (json->require dict)
(if dict (if dict
(let loop ((result '()) (require dict)) (let loop ((result '()) (require dict))
@ -102,31 +100,25 @@
(not (string-contains d "beta")) (not (string-contains d "beta"))
(not (string-contains d "rc"))))) (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 "Return a composer-package representation of the Composer metadata for the
package NAME with optional VERSION, or #f on failure." package NAME with optional VERSION, or #f on failure. VERSION may be gien as
(let* ((url (string-append (%composer-base-url) "/p/" name ".json")) version prefix if PARTIAL-VERSION? is #t."
(packages (and=> (json-fetch url) (and-let* ((url (string-append (%composer-base-url) "/p/" name ".json"))
(lambda (pkg) (packages (and=> (json-fetch url)
(let ((pkgs (assoc-ref pkg "packages"))) (lambda (pkg)
(or (assoc-ref pkgs name) pkg)))))) (let ((pkgs (assoc-ref pkg "packages")))
(if packages (or (assoc-ref pkgs name) pkg)))))
(json->composer-package (all-versions (map car packages))
(if version (valid-versions (filter valid-version? all-versions))
(assoc-ref packages version) (version (or (find-version valid-versions version partial-version?)
(cdr (and version
(fold ;; If the user-provided VERSION could not be
(lambda (new cur-max) ;; found, fallback to look through all
(match new ;; versions.
(((? valid-version? version) . tail) (find-version all-versions version
(if (version>? (fix-version version) partial-version?)))))
(fix-version (car cur-max))) (json->composer-package (assoc-ref packages version))))
(cons* version tail)
cur-max))
(_ cur-max)))
(cons* "0.0.0" #f)
packages))))
#f)))
(define (php-package-name name) (define (php-package-name name)
"Given the NAME of a package on Packagist, return a Guix-compliant name for "Given the NAME of a package on Packagist, return a Guix-compliant name for
@ -246,10 +238,15 @@ package in Packagist."
(downstream-name (php-package-name dependency)) (downstream-name (php-package-name dependency))
(type type))) (type type)))
(define* (import-release package #:key (version #f)) (define* (import-release package #:key version partial-version?)
"Return an <upstream-source> for VERSION or the latest release of PACKAGE." "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)) (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 (if composer-package
(upstream-source (upstream-source
(package (composer-package-name composer-package)) (package (composer-package-name composer-package))

2
guix/import/cpan.scm
View file

@ -328,7 +328,7 @@ in RELEASE, a <cpan-release> record."
")")))) ")"))))
(url-predicate (cut regexp-exec cpan-rx <>)))) (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." "Return an <upstream-source> for the latest release of PACKAGE."
(when version (when version
(raise (raise

4
guix/import/cran.scm
View file

@ -1028,7 +1028,7 @@ s-expression corresponding to that package, or #f on failure."
(_ #f))) (_ #f)))
(_ #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." "Return an <upstream-source> for the latest release of the package PKG."
(when version (when version
(error (error
@ -1051,7 +1051,7 @@ s-expression corresponding to that package, or #f on failure."
(urls (cran-uri upstream-name version)) (urls (cran-uri upstream-name version))
(inputs (cran-package-inputs meta 'cran)))))) (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." "Return an <upstream-source> for the latest release of the package PKG."
(when version (when version
(error (error

51
guix/import/crate.scm
View file

@ -7,6 +7,7 @@
;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2023, 2024 David Elsing <david.elsing@posteo.net> ;;; Copyright © 2023, 2024 David Elsing <david.elsing@posteo.net>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2025 Herman Rimm <herman@rimm.ee> ;;; Copyright © 2025 Herman Rimm <herman@rimm.ee>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -278,8 +279,9 @@ and LICENSE."
(loop curr remaining) (loop curr remaining)
(loop next remaining)))))) (loop next remaining))))))
(define (max-crate-version-of-semver semver-range range) (define (max-crate-version-of-semver semver-range versions)
"Returns a <crate-version> of the highest version within the semver range." "Returns the <crate-version> of the highest version found in VERSIONS that
satisfies SEMVER-RANGE."
(define (crate->semver crate) (define (crate->semver crate)
(string->semver (crate-version-number crate))) (string->semver (crate-version-number crate)))
@ -287,7 +289,7 @@ and LICENSE."
(min-element (min-element
(filter (lambda (crate) (filter (lambda (crate)
(semver-range-contains? semver-range (crate->semver crate))) (semver-range-contains? semver-range (crate->semver crate)))
range) versions)
(lambda args (lambda args
(apply semver>? (map crate->semver args))))) (apply semver>? (map crate->semver args)))))
@ -491,25 +493,34 @@ look up the development dependencs for the given crate."
(define crate-package? (define crate-package?
(url-predicate crate-url?)) (url-predicate crate-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 "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 partial
prefix when PARTIAL-VERSION? is #t."
(let* ((crate-name (guix-package->crate-name package)) (let* ((crate-name (guix-package->crate-name package))
(crate (lookup-crate crate-name)) (crate (lookup-crate crate-name))
(version (or version (versions (delay (nonyanked-crate-versions crate)))
(let ((max-crate-version (find-max-minor-patch-version (lambda (base-version)
(max-crate-version-of-semver (max-crate-version-of-semver
(string->semver-range (string->semver-range
(string-append "^" (package-version package))) (string-append
(nonyanked-crate-versions crate)))) "^" base-version))
(and=> max-crate-version (force versions))))
crate-version-number))))) (version (cond
(if version ((and version partial-version?) ;partial version
(upstream-source (and=> (find-max-minor-patch-version version)
(package (package-name package)) crate-version-number))
(version version) ((and version (not partial-version?)) ;exact version
(urls (list (crate-uri crate-name version)))) version)
#f))) (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 (define %crate-updater
(upstream-updater (upstream-updater

33
guix/import/egg.scm
View file

@ -4,6 +4,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2024 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; Copyright © 2024 Ekaitz Zarraga <ekaitz@elenq.tech>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -24,6 +25,7 @@
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (guix git) #:use-module (guix git)
@ -99,12 +101,9 @@ to the repository."
(let ((eggs-directory (eggs-repository))) (let ((eggs-directory (eggs-repository)))
(string-append eggs-directory "/" name))) (string-append eggs-directory "/" name)))
(define (find-latest-version name) (define (get-versions name)
"Get the latest version of the egg NAME." "Get the release versions of the egg NAME."
(let ((directory (scandir (egg-directory name)))) (or (scandir (egg-directory name)) '()))
(if directory
(last directory)
#f)))
(define* (egg-metadata name #:key (version #f) (file #f)) (define* (egg-metadata name #:key (version #f) (file #f))
"Return the package metadata file for the egg NAME at version VERSION, or if "Return the package metadata file for the egg NAME at version VERSION, or if
@ -112,7 +111,7 @@ FILE is specified, return the package metadata in FILE."
(call-with-input-file (or file (call-with-input-file (or file
(string-append (egg-directory name) "/" (string-append (egg-directory name) "/"
(or version (or version
(find-latest-version name)) (first (get-versions name)))
"/" name ".egg")) "/" name ".egg"))
read)) read))
@ -188,7 +187,7 @@ not work."
(if (not egg-content) (if (not egg-content)
(values #f '()) ; egg doesn't exist (values #f '()) ; egg doesn't exist
(let* ((version* (or (assoc-ref egg-content 'version) (let* ((version* (or (assoc-ref egg-content 'version)
(find-latest-version name))) (first (get-versions name))))
(version (if (list? version*) (first version*) version*)) (version (if (list? version*) (first version*) version*))
(source-url (if source #f `(egg-uri ,name version))) (source-url (if source #f `(egg-uri ,name version)))
(tarball (if source (tarball (if source
@ -333,16 +332,18 @@ not work."
;;; Updater. ;;; 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. "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)) (let* ((egg-name (guix-package->egg-name package))
(version (or version (find-latest-version egg-name))) (versions (get-versions egg-name))
(source-url (egg-uri egg-name version))) (version (find-version versions version partial-version?)))
(upstream-source (and version
(package (package-name package)) (upstream-source
(version version) (package (package-name package))
(urls (list source-url))))) (version version)
(urls (list (egg-uri egg-name version)))))))
(define %egg-updater (define %egg-updater
(upstream-updater (upstream-updater

2
guix/import/elpa.scm
View file

@ -422,7 +422,7 @@ type '<elpa-package>'."
(string-drop (package-name package) 6) (string-drop (package-name package) 6)
(package-name package)))) (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." "Return an <upstream-release> for the latest release of PACKAGE."
(define name (guix-package->elpa-name package)) (define name (guix-package->elpa-name package))
(define repo (elpa-repository package)) (define repo (elpa-repository package))

29
guix/import/gem.scm
View file

@ -7,6 +7,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,6 +27,7 @@
(define-module (guix import gem) (define-module (guix import gem)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (json) #:use-module (json)
#:use-module (guix import utils) #:use-module (guix import utils)
#:use-module (guix import json) #:use-module (guix import json)
@ -35,6 +37,7 @@
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix build-system ruby) #:select (rubygems-uri)) #:use-module ((guix build-system ruby) #:select (rubygems-uri))
#:use-module ((guix utils) #:select (version>? version-prefix?))
#:export (gem->guix-package #:export (gem->guix-package
%gem-updater %gem-updater
gem-recursive-import)) gem-recursive-import))
@ -90,6 +93,15 @@
(string-append "https://rubygems.org/api/v1/gems/" name ".json"))) (string-append "https://rubygems.org/api/v1/gems/" name ".json")))
json->gem)) 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) (define (ruby-package-name name)
"Given the NAME of a package on RubyGems, return a Guix-compliant name for "Given the NAME of a package on RubyGems, return a Guix-compliant name for
the package." the package."
@ -172,7 +184,7 @@ package on RubyGems."
(define gem-package? (define gem-package?
(url-prefix-predicate "https://rubygems.org/downloads/")) (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." "Return an <upstream-source> for the latest release of PACKAGE."
(let* ((gem-name (guix-package->gem-name package)) (let* ((gem-name (guix-package->gem-name package))
(gem (rubygems-fetch gem-name)) (gem (rubygems-fetch gem-name))
@ -184,13 +196,14 @@ package on RubyGems."
(ruby-package-name name)) (ruby-package-name name))
(type 'propagated)))) (type 'propagated))))
(gem-dependencies-runtime (gem-dependencies gem)))) (gem-dependencies-runtime (gem-dependencies gem))))
(version (or version (gem-version gem))) (versions (get-versions gem-name))
(url (rubygems-uri gem-name version))) (version (find-version versions version partial-version?)))
(upstream-source (and version
(package (package-name package)) (upstream-source
(version version) (package (package-name package))
(urls (list url)) (version version)
(inputs inputs)))) (urls (list (rubygems-uri gem-name version)))
(inputs inputs)))))
(define %gem-updater (define %gem-updater
(upstream-updater (upstream-updater

99
guix/import/git.scm
View file

@ -26,7 +26,7 @@
#:use-module (guix git-download) #:use-module (guix git-download)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix upstream) #: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 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -34,10 +34,7 @@
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:export (%generic-git-updater #:export (%generic-git-updater))
;; For tests.
latest-git-tag-version))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -121,7 +118,9 @@ version corresponding to the tag, and the cdr is the name of the tag."
;; with "." ;; with "."
pre-release-rx suffix-rx)) pre-release-rx suffix-rx))
(define (pre-release? tag)
(any (cut regexp-exec <> tag)
%pre-release-rx))
(define (get-version tag) (define (get-version tag)
(let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) (let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
@ -135,30 +134,20 @@ version corresponding to the tag, and the cdr is the name of the tag."
(string-append version (match:substring tag-match 3)) (string-append version (match:substring tag-match 3))
version))))) version)))))
(define (entry<? a b) (filter-map (lambda (tag)
(eq? (version-compare (car a) (car b)) '<)) (let ((version (get-version tag)))
(and version
(or pre-releases?
(not (pre-release? version)))
(cons version tag))))
tags))
(define (pre-release? tag) (define* (get-tags url #:key prefix suffix delim pre-releases?)
(any (cut regexp-exec <> tag) "Return a alist of the Git tags available from URL. The tags are keyed by
%pre-release-rx)) their version, a mapping derived from their name."
(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."
(let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) (let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
(remote-refs url #:tags? #t))) (remote-refs url #:tags? #t)))
(versions->tags (versions+tags
(version-mapping tags (version-mapping tags
#:prefix prefix #:prefix prefix
#:suffix suffix #:suffix suffix
@ -167,47 +156,38 @@ version."
(cond (cond
((null? tags) ((null? tags)
(git-no-tags-error)) (git-no-tags-error))
((null? versions->tags) ((null? versions+tags)
(git-no-valid-tags-error)) (git-no-valid-tags-error))
(else (else
(let ((versions (if version versions+tags)))) ;already sorted
(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)) (define* (get-package-tags package)
"Given a PACKAGE, return the latest version of it and the corresponding git "Given a PACKAGE, return all its known tags, an alist keyed by the tags
tag, or #false and #false if the latest version could not be determined. associated versions. "
Optionally include a VERSION string to fetch a specific version."
(guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
(warning (or (package-field-location package 'source) (warning (or (package-field-location package 'source)
(package-location package)) (package-location package))
(G_ "~a for ~a~%") (G_ "~a for ~a~%")
(condition-message c) (condition-message c)
(package-name package)) (package-name package))
(values #f #f)) '())
((eq? (exception-kind c) 'git-error) ((eq? (exception-kind c) 'git-error)
(warning (or (package-field-location package 'source) (warning (or (package-field-location package 'source)
(package-location package)) (package-location package))
(G_ "failed to fetch Git repository for ~a~%") (G_ "failed to fetch Git repository for ~a~%")
(package-name package)) (package-name package))
(values #f #f))) '()))
(let* ((source (package-source package)) (let* ((source (package-source package))
(url (git-reference-url (origin-uri source))) (url (git-reference-url (origin-uri source)))
(property (cute assq-ref (package-properties package) <>))) (property (cute assq-ref (package-properties package) <>)))
(latest-tag url (get-tags url
#:version version #:prefix (property 'release-tag-prefix)
#:prefix (property 'release-tag-prefix) #:suffix (property 'release-tag-suffix)
#:suffix (property 'release-tag-suffix) #:delim (property 'release-tag-version-delimiter)
#:delim (property 'release-tag-version-delimiter) #:pre-releases? (property 'accept-pre-releases?)))))
#: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) (define (git-package? package)
"Return true if PACKAGE is hosted on a Git repository." "Return true if PACKAGE is hosted on a Git repository."
@ -217,21 +197,24 @@ Optionally include a VERSION string to fetch a specific version."
(git-reference? (origin-uri origin)))) (git-reference? (origin-uri origin))))
(_ #f))) (_ #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. "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)) (let* ((name (package-name package))
(old-version (package-version package)) (old-version (package-version package))
(old-reference (origin-uri (package-source package))) (old-reference (origin-uri (package-source package)))
(new-version new-version-tag (tags (get-package-tags package))
(latest-git-tag-version package #:version version))) (versions (map car tags))
(and new-version new-version-tag (version (find-version versions version partial-version?))
(tag (assoc-ref tags version)))
(and version
(upstream-source (upstream-source
(package name) (package name)
(version new-version) (version version)
(urls (git-reference (urls (git-reference
(url (git-reference-url old-reference)) (url (git-reference-url old-reference))
(commit new-version-tag) (commit tag)
(recursive? (git-reference-recursive? old-reference)))))))) (recursive? (git-reference-recursive? old-reference))))))))
(define %generic-git-updater (define %generic-git-updater

114
guix/import/github.scm
View file

@ -7,6 +7,7 @@
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> ;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -30,7 +31,8 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-71) #: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 i18n)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module ((guix ui) #:select (display-hint)) #:use-module ((guix ui) #:select (display-hint))
@ -246,40 +248,49 @@ Alternatively, you can wait until your rate limit is reset, or use the
#:headers headers)))) #:headers headers))))
(match result (match result
(#() (#()
;; We got the empty list, presumably because the user didn't use GitHub's ;; We got the empty list, presumably because the user
;; "release" mechanism, but hopefully they did use Git tags. ;; didn't use GitHub's "release" mechanism, but hopefully
;; they did use Git tags.
(json->scm (http-fetch tag-url (json->scm (http-fetch tag-url
#:port connection #:port connection
#:keep-alive? #t #:keep-alive? #t
#:headers headers))) #:headers headers)))
(x x))))))))) (x x)))))))))
(define* (latest-released-version url package-name #:key (version #f)) (define* (get-package-tags package)
"Return the newest released version and its tag given a string URL like "Return an alist of tags keyed by their version for PACKAGE, a <package>
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of object."
the package e.g. 'bedtools2'. Return #f (two values) if there are no (define (github-uri uri)
releases. (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) (define (pre-release? x)
(assoc-ref x "prerelease")) (assoc-ref x "prerelease"))
(define source-uri
(github-uri (origin-uri (package-source package))))
;; This procedure returns (version . tag) pair, or #f ;; This procedure returns (version . tag) pair, or #f
;; if RELEASE doesn't seyem to correspond to a version. ;; if RELEASE doesn't seyem to correspond to a version.
(define (release->version release) (define (release->version release)
(let ((tag (or (assoc-ref release "tag_name") ;a "release" (let* ((tag (or (assoc-ref release "tag_name") ;a "release"
(assoc-ref release "name"))) ;a tag (assoc-ref release "name"))) ;a tag
(name-length (string-length package-name))) (name (package-upstream-name package))
(name-length (string-length name)))
(cond (cond
;; some tags include the name of the package e.g. "fdupes-1.51" ;; Some tags include the name of the package e.g. "fdupes-1.51"; remove
;; so remove these ;; these.
((and (< name-length (string-length tag)) ((and (< name-length (string-length tag))
(string=? (string-append package-name "-") (string=? (string-append name "-")
(substring tag 0 (+ name-length 1)))) (substring tag 0 (+ name-length 1))))
(cons (substring tag (+ name-length 1)) tag)) (cons (substring tag (+ name-length 1)) tag))
;; some tags start with a "v" e.g. "v0.25.0" ;; Some tags start with a "v" e.g. "v0.25.0" or with the word "version"
;; or with the word "version" e.g. "version.2.1" ;; e.g. "version.2.1" where some are just the version number.
;; where some are just the version number
((string-prefix? "version" tag) ((string-prefix? "version" tag)
(cons (if (char-set-contains? char-set:digit (string-ref tag 7)) (cons (if (char-set-contains? char-set:digit (string-ref tag 7))
(substring tag 7) (substring tag 7)
@ -294,53 +305,32 @@ Optionally include a VERSION string to fetch a specific version."
(cons tag tag)) (cons tag tag))
(else #f)))) (else #f))))
(match (and=> (fetch-releases-or-tags url) vector->list) (match (and=> (fetch-releases-or-tags source-uri) vector->list)
(#f (values #f #f)) (#f '())
(json (json
(let ((releases (filter-map release->version (filter-map release->version
(match (remove pre-release? json) (match (remove pre-release? json)
(() json) ; keep everything (() json) ;keep everything
(releases releases))))) (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)))))))
(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. "Return an <upstream-source> for the latest release of PKG.
Optionally include a VERSION string to fetch a specific version." Optionally include a VERSION string to fetch a specific version, which may be
(define (github-uri uri) a partial version prefix if PARTIAL-VERSION? is #t."
(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))))
(let* ((original-uri (origin-uri (package-source pkg))) (let* ((original-uri (origin-uri (package-source pkg)))
(source-uri (github-uri original-uri)) (tags (get-package-tags pkg))
(name (package-upstream-name pkg)) (versions (map car tags))
(newest-version version-tag (version (find-version versions version partial-version?))
(latest-released-version source-uri name (tag (assoc-ref tags version)))
#:version version))) (and version
(if newest-version (upstream-source
(upstream-source (package (package-upstream-name pkg))
(package name) (version version)
(version newest-version) (urls (if (download:git-reference? original-uri)
(urls (if (download:git-reference? original-uri) (download:git-reference
(download:git-reference (inherit original-uri)
(inherit original-uri) (commit tag))
(commit version-tag)) (list (updated-github-url pkg version))))))))
(list (updated-github-url pkg newest-version)))))
#f))) ; On GitHub but no proper releases
(define %github-updater (define %github-updater
(upstream-updater (upstream-updater
@ -348,5 +338,3 @@ Optionally include a VERSION string to fetch a specific version."
(description "Updater for GitHub packages") (description "Updater for GitHub packages")
(pred github-package?) (pred github-package?)
(import import-release))) (import import-release)))

50
guix/import/gnome.scm
View file

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019, 2021, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2019, 2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2022, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -19,14 +19,15 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import gnome) (define-module (guix import gnome)
#:use-module ((guix import utils) #:select (find-version))
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (guix i18n) #:use-module (guix i18n)
#:use-module (json) #:use-module (json)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (web uri) #:use-module (web uri)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -58,10 +59,10 @@ source for metadata."
name "/" relative-url)))) name "/" relative-url))))
'("tar.lz" "tar.xz" "tar.bz2" "tar.gz"))))))) '("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 "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 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 (define %not-dot
(char-set-complement (char-set #\.))) (char-set-complement (char-set #\.)))
@ -90,28 +91,6 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235"
;; Some packages like "NetworkManager" have camel-case names. ;; Some packages like "NetworkManager" have camel-case names.
(package-upstream-name package)) (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) (guard (c ((http-get-error? c)
(unless (= 404 (http-get-error-code c)) (unless (= 404 (http-get-error-code c))
(warning (G_ "failed to download from '~a': ~a (~s)~%") (warning (G_ "failed to download from '~a': ~a (~s)~%")
@ -135,11 +114,20 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235"
(match json (match json
(#(4 releases _ ...) (#(4 releases _ ...)
(let* ((releases (assoc-ref releases upstream-name)) (let* ((releases (assoc-ref releases upstream-name))
(latest (if version (all-versions (map car releases))
(find-version-release releases version) (release-versions (filter release-version? all-versions))
(find-latest-release releases)))) (version (or (find-version release-versions
(and latest version partial-version?)
(jsonish->upstream-source upstream-name latest)))))))) (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 (define %gnome-updater
(upstream-updater (upstream-updater

2
guix/import/hackage.scm
View file

@ -379,7 +379,7 @@ respectively."
(let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)")))
(url-predicate (cut regexp-exec hackage-rx <>)))) (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." "Return an <upstream-source> for the latest release of PACKAGE."
(let* ((hackage-name (package-upstream-name* package)) (let* ((hackage-name (package-upstream-name* package))
(cabal-meta (hackage-fetch hackage-name version))) (cabal-meta (hackage-fetch hackage-name version)))

42
guix/import/hexpm.scm
View file

@ -3,7 +3,7 @@
;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017, 2019-2021, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2019-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020-2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2020-2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -32,7 +32,7 @@
call-with-temporary-output-file)) call-with-temporary-output-file))
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix upstream) #: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 (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -95,7 +95,7 @@
(define (lookup-hexpm name) (define (lookup-hexpm name)
"Look up NAME on hex.pm and return the corresponding <hexpm> record "Look up NAME on hex.pm and return the corresponding <hexpm-pkgdef> record
or #f if it was not found." or #f if it was not found."
(and=> (json-fetch (package-url name)) (and=> (json-fetch (package-url name))
json->hexpm)) json->hexpm))
@ -215,16 +215,11 @@ build-system, and DEPENDENCIES the inputs for the package."
license))) license)))
strings)) strings))
(define (hexpm-latest-release package) (define (hexpm-releases package)
"Return the version string for the latest stable release of PACKAGE." "Return the version strings for releases of PACKAGE, a <hexpm-pkgdef>
;; Use latest-stable if specified (see comment in hexpm-pkgdef above), object, ordered from newest to oldest."
;; otherwise compare the lists of release versions. (sort (map hexpm-version-number (hexpm-versions package))
(let ((latest-stable (hexpm-latest-stable package))) version>?))
(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->guix-package package-name #:key version #:allow-other-keys) (define* (hexpm->guix-package package-name #:key version #:allow-other-keys)
"Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the "Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the
@ -238,7 +233,7 @@ latest version of PACKAGE-NAME."
(define version-number (define version-number
(and package (and package
(or version (or version
(hexpm-latest-release package)))) (first (hexpm-releases package)))))
(define version* (define version*
(and package (and package
@ -320,17 +315,20 @@ latest version of PACKAGE-NAME."
;;; Updater ;;; 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 "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)) (let* ((hexpm-name (guix-package->hexpm-name package))
(hexpm (lookup-hexpm hexpm-name)) (hexpm (lookup-hexpm hexpm-name))
(version (or version (hexpm-latest-release hexpm))) (latest-stable (hexpm-latest-stable hexpm))
(url (hexpm-uri hexpm-name version))) (releases (hexpm-releases hexpm))
(upstream-source (version (find-version releases version partial-version?)))
(package (package-name package)) (and version
(version version) (upstream-source
(urls (list url))))) (package (package-name package))
(version version)
(urls (list (hexpm-uri hexpm-name version)))))))
(define %hexpm-updater (define %hexpm-updater
(upstream-updater (upstream-updater

57
guix/import/kde.scm
View file

@ -2,6 +2,7 @@
;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -19,6 +20,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import kde) (define-module (guix import kde)
#:use-module ((guix import utils) #:select (find-version))
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix gnu-maintenance) #:use-module (guix gnu-maintenance)
#:use-module (guix packages) #:use-module (guix packages)
@ -149,48 +151,39 @@ Output:
(string-join (map version->pattern directory-parts) "/") (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 "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 not be determined. Optionally include a VERSION string to fetch a specific
version." version, which may be a partial prefix when PARTIAL-VERSION? is #t."
(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))
(let* ((uri (string->uri (origin-uri (package-source package)))) (let* ((uri (string->uri (origin-uri (package-source package))))
(path-rx (uri->kde-path-pattern uri)) (path-rx (uri->kde-path-pattern uri))
(name (package-upstream-name package)) (name (package-upstream-name package))
(files (download.kde.org-files)) (files (download.kde.org-files))
;; select archives for this package ;; Select archives for this package.
(relevant (filter (lambda (file) (relevant (filter (lambda (file)
(and (regexp-exec path-rx file) (and (regexp-exec path-rx file)
(release-file? name (basename file)))) (release-file? name (basename file))))
files)) files))
;; Find latest version. ;; Build an association list of file names keyed by their version.
(version (or version (all-tarballs (map (lambda (x)
(and (not (null? relevant)) (cons (tarball->version x) x))
(tarball->version (find-latest-archive-version relevant))))) relevant))
;; Find archives matching this version. (versions (map car all-tarballs))
(tarballs (filter (lambda (file) ;; Find the latest version.
(string=? version (tarball->version file))) (version (find-version versions version partial-version?))
relevant))) ;; Find all archives matching this version.
(match tarballs (tarballs (and version
(() #f) (map cdr (filter (match-lambda
(_ ((x . file-name)
(upstream-source (string=? version x)))
(package name) all-tarballs)))))
(version version) (and version tarballs
(urls (map (lambda (file) (upstream-source
(string-append "mirror://kde/" file)) (package name)
tarballs))))))) (version version)
(urls (map (lambda (file)
(string-append "mirror://kde/" file))
tarballs))))))
(define %kde-updater (define %kde-updater
(upstream-updater (upstream-updater

36
guix/import/launchpad.scm
View file

@ -3,6 +3,7 @@
;;; Copyright © 2021 Matthew James Kraai <kraai@ftbfs.org> ;;; Copyright © 2021 Matthew James Kraai <kraai@ftbfs.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,9 +27,10 @@
#:use-module (web uri) #:use-module (web uri)
#:use-module ((guix download) #:prefix download:) #:use-module ((guix download) #:prefix download:)
#:use-module (guix import json) #:use-module (guix import json)
#:use-module ((guix import utils) #:select (find-version))
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix utils) #:use-module ((guix utils) #:select (version-major+minor))
#:export (%launchpad-updater)) #:export (%launchpad-updater))
(define (find-extension url) (define (find-extension url)
@ -103,9 +105,9 @@ URL of the form
(match (string-split (uri-path (string->uri url)) #\/) (match (string-split (uri-path (string->uri url)) #\/)
((_ repo . rest) repo))) ((_ repo . rest) repo)))
(define (latest-released-version repository) (define (release-versions repository)
"Return a string of the newest released version name given the REPOSITORY, "Return a list of the release version strings available for REPOSITORY, a
for example, 'linuxdcpp'. Return #f if there is no releases." repository name such as 'linuxdcpp'."
(define (pre-release? x) (define (pre-release? x)
;; Versions containing anything other than digit characters and "." (for ;; Versions containing anything other than digit characters and "." (for
;; example, "5.1.0-rc1") are assumed to be pre-releases. ;; example, "5.1.0-rc1") are assumed to be pre-releases.
@ -116,31 +118,31 @@ for example, 'linuxdcpp'. Return #f if there is no releases."
(match (json-fetch (match (json-fetch
(string-append "https://api.launchpad.net/1.0/" (string-append "https://api.launchpad.net/1.0/"
repository "/releases")) repository "/releases"))
(#f #f) ;404 or similar (#f #f) ;404 or similar
(json (json
(assoc-ref (let ((releases (remove pre-release?
(last (remove pre-release? (vector->list (assoc-ref json "entries")))) (vector->list (assoc-ref json "entries")))))
"version")))) (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 "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) (define (origin-launchpad-uri origin)
(match (origin-uri origin) (match (origin-uri origin)
((? string? url) url) ; surely a Launchpad URL ((? string? url) url) ;surely a Launchpad URL
((urls ...) ((urls ...)
(find (cut string-contains <> "launchpad.net") urls)))) (find (cut string-contains <> "launchpad.net") urls))))
(let* ((source-uri (origin-launchpad-uri (package-source pkg))) (let* ((source-uri (origin-launchpad-uri (package-source pkg)))
(name (package-name pkg)) (name (package-name pkg))
(repository (launchpad-repository source-uri)) (versions (release-versions (launchpad-repository source-uri)))
(newest-version (or version (latest-released-version repository)))) (version (find-version versions version partial-version?)))
(if newest-version (and version
(upstream-source (upstream-source
(package name) (package name)
(version newest-version) (version version)
(urls (list (updated-launchpad-url pkg newest-version)))) (urls (list (updated-launchpad-url pkg version)))))))
#f))) ; On Launchpad but no proper releases
(define %launchpad-updater (define %launchpad-updater
(upstream-updater (upstream-updater

2
guix/import/minetest.scm
View file

@ -483,7 +483,7 @@ list of AUTHOR/NAME strings."
(and (string-prefix? "minetest-" (package:package-name pkg)) (and (string-prefix? "minetest-" (package:package-name pkg))
(assq-ref (package:package-properties pkg) 'upstream-name))) (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, "Return an <upstream-source> for the latest release of the package PKG,
or #false if the latest release couldn't be determined." or #false if the latest release couldn't be determined."
(define author/name (define author/name

2
guix/import/opam.scm
View file

@ -417,7 +417,7 @@ package in OPAM."
(member (build-system-name (package-build-system package)) '(dune ocaml)) (member (build-system-name (package-build-system package)) '(dune ocaml))
(not (string-prefix? "ocaml4" (package-name package))))) (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." "Return an <upstream-source> for the latest release of PACKAGE."
(when version (when version
(raise (raise

25
guix/import/pypi.scm
View file

@ -35,6 +35,7 @@
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
@ -522,11 +523,17 @@ pypi-uri declaration in the generated package. You may need to replace ~s with
a substring of the PyPI URI that identifies the package.") pypi-url name)) a substring of the PyPI URI that identifies the package.") pypi-url name))
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 "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)) (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)) (dist (source-release pypi-package version))
(source-url (distribution-url dist)) (source-url (distribution-url dist))
(wheel-url (and=> (wheel-release pypi-package version) (wheel-url (and=> (wheel-release pypi-package version)
@ -661,14 +668,14 @@ source. To build it from source, refer to the upstream repository at
(string-prefix? "https://pypi.org/packages" url) (string-prefix? "https://pypi.org/packages" url)
(string-prefix? "https://files.pythonhosted.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 "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."
(let* ((pypi-name (guix-package->pypi-name package)) (and-let* ((pypi-name (guix-package->pypi-name package))
(pypi-package (pypi-fetch pypi-name))) (pypi-package (pypi-fetch pypi-name)))
(and pypi-package (guard (c ((missing-source-error? c) #f))
(guard (c ((missing-source-error? c) #f)) (pypi-package->upstream-source pypi-package
(pypi-package->upstream-source pypi-package version))))) version partial-version?))))
(define %pypi-updater (define %pypi-updater
(upstream-updater (upstream-updater

2
guix/import/stackage.scm
View file

@ -142,7 +142,7 @@ included in the Stackage LTS release."
(mlambda () (mlambda ()
(stackage-lts-packages (stackage-lts-packages
(stackage-lts-info-fetch %default-lts-version))))) (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 "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." PACKAGE or #f if the package is not included in the Stackage LTS release."
(when version (when version

15
guix/import/test.scm
View file

@ -18,6 +18,8 @@
(define-module (guix import test) (define-module (guix import test)
#:use-module (srfi srfi-1) #: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 packages)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module ((guix utils) #:select (version-prefix?)) #:use-module ((guix utils) #:select (version-prefix?))
@ -76,18 +78,17 @@
(and (not (vlist-null? (test-target-version))) ;cheap test (and (not (vlist-null? (test-target-version))) ;cheap test
(pair? (available-updates package)))) (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 "Return the <upstream-source> record denoting either the latest version of
PACKAGE or VERSION." PACKAGE or VERSION."
(match (available-updates package) (match (available-updates package)
(() #f) (() #f)
((sources ...) ((sources ...)
(if version (let* ((versions (map upstream-source-version sources))
(find (lambda (source) (version (find-version versions version partial-version?)))
(string=? (upstream-source-version source) (and version
version)) (find (compose (cut string=? version <>) upstream-source-version)
sources) sources))))))
(first sources)))))
(define %test-updater (define %test-updater
(upstream-updater (upstream-updater

38
guix/import/texlive.scm
View file

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; Copyright © 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -35,7 +35,8 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix svn-download) #:use-module (guix svn-download)
#:use-module (guix upstream) #: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 ftw)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 popen) #:use-module (ice-9 popen)
@ -261,17 +262,21 @@ not succeed."
"Return number of days since Epoch." "Return number of days since Epoch."
(floor (/ (time-second (current-time)) (* 24 60 60)))) (floor (/ (time-second (current-time)) (* 24 60 60))))
(define latest-texlive-tag (define texlive-tags
;; 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.
(memoize (memoize
(lambda* (#:key (day (current-day))) (lambda* (#:key (day (current-day)))
(let ((output "Return all tags found in for the TeX Live tags in repository, from
(svn-command "ls" (string-append %texlive-repository "tags") "-v"))) latest to oldest. The argument refers to current day, so memoization is only
;; E.g. "70951 karl april 15 18:11 texlive-2024.2/\n\n" active a single day, as the repository may have been updated between two
(and=> (string-match "texlive-([^/]+)/\n*$" output) calls."
(cut match:substring <> 1)))))) (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 (define string->license
(match-lambda (match-lambda
@ -761,7 +766,7 @@ associated Guix package, or #f on failure. Fetch metadata for a specific
version whenever VERSION keyword is specified. Otherwise, grab package latest version whenever VERSION keyword is specified. Otherwise, grab package latest
release. When DATABASE is provided, fetch metadata from there, ignoring release. When DATABASE is provided, fetch metadata from there, ignoring
VERSION." VERSION."
(let ((version (or version (latest-texlive-tag)))) (let ((version (or version (first (texlive-tags)))))
(tlpdb->package name version (or database (tlpdb/cached version)))))) (tlpdb->package name version (or database (tlpdb/cached version))))))
(define* (texlive-recursive-import name #:key repo version) (define* (texlive-recursive-import name #:key repo version)
@ -785,13 +790,14 @@ VERSION."
(eq? 'texlive (eq? 'texlive
(build-system-name (package-build-system package))))))) (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 "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 partial
(let* ((version (or version (latest-texlive-tag))) prefix when PARTIAL-VERSION? is #t."
(let* ((version (find-version (texlive-tags) version partial-version?))
(database (tlpdb/cached version)) (database (tlpdb/cached version))
(upstream-name (package-upstream-name* package))) (upstream-name (package-upstream-name* package)))
(and (assoc-ref database upstream-name) (and version (assoc-ref database upstream-name)
(upstream-source (upstream-source
(package upstream-name) (package upstream-name)
(version version) (version version)

20
guix/import/utils.scm
View file

@ -7,7 +7,7 @@
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr>
@ -85,6 +85,8 @@
guix-name guix-name
find-version
recursive-import)) recursive-import))
(define (factorize-uri uri version) (define (factorize-uri uri version)
@ -620,6 +622,22 @@ separated by PRED."
(define-deprecated/alias guix-name downstream-package-name) (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 (define (topological-sort nodes
node-dependencies node-dependencies
node-name) node-name)

186
guix/scripts/refresh.scm
View file

@ -10,7 +10,7 @@
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2023, 2025 Maxim Cournoyer maxim.cournoyer@gmail.com> ;;; Copyright © 2023-2025 Maxim Cournoyer maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -170,7 +170,9 @@ specified with `--select'.\n"))
-m, --manifest=FILE select all the packages from the manifest in FILE")) -m, --manifest=FILE select all the packages from the manifest in FILE"))
(display (G_ " (display (G_ "
--target-version=VERSION --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_ " (display (G_ "
-t, --type=UPDATER,... restrict to updates from the specified updaters -t, --type=UPDATER,... restrict to updates from the specified updaters
(e.g., 'gnu')")) (e.g., 'gnu')"))
@ -213,20 +215,22 @@ specified with `--select'.\n"))
;;; ;;;
(define-record-type <update-spec> (define-record-type <update-spec>
(%update-spec package version) (%update-spec package version partial?)
update? update?
(package update-spec-package) (package update-spec-package)
(version update-spec-version)) (version update-spec-version)
(partial? update-spec-partial?))
(define* (update-spec package #:optional version) (define* (update-spec package #:optional version partial?)
(%update-spec package version)) (%update-spec package version partial?))
(define (update-specification->update-spec spec fallback-version) (define (update-specification->update-spec spec fallback-version)
"Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update> "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update>
record with two fields: the package to upgrade, and the target version. When record with two fields: the package to upgrade, and the target version. When
SPEC lacks a version, use FALLBACK-VERSION." SPEC lacks a version, use FALLBACK-VERSION."
(match (string-rindex spec #\=) (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)) (idx (update-spec (specification->package (substring spec 0 idx))
(substring spec (1+ idx)))))) (substring spec (1+ idx))))))
@ -282,9 +286,9 @@ update would trigger a complete rebuild."
spec target-version))) spec target-version)))
(('expression . exp) (('expression . exp)
(list (update-spec (read/eval-package-expression exp) (list (update-spec (read/eval-package-expression exp)
target-version))) target-version #t)))
(('manifest . manifest) (('manifest . manifest)
(map (cut update-spec <> target-version) (map (cut update-spec <> target-version #t)
(packages-from-manifest manifest))) (packages-from-manifest manifest)))
(_ (_
'())) '()))
@ -364,92 +368,97 @@ update would trigger a complete rebuild."
(G_ "no updater for ~a~%") (G_ "no updater for ~a~%")
(package-name package))) (package-name package)))
(define* (update-package store package version updaters (define* (update-package store update-spec updaters
#:key (key-download 'auto) key-server #:key (key-download 'auto) key-server
warn?) warn?)
"Update the source file that defines PACKAGE with the new version. "Update the source file that correspond to the package in UPDATE-SPEC,
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed an <update-spec> object. KEY-DOWNLOAD specifies a download policy for
values: 'auto' (default), interactive', 'always', and 'never'. When WARN? is missing OpenPGP keys; allowed values: 'auto' (default), 'interactive',
true, warn about packages that have no matching updater." 'always', and 'never'. When WARN? is true, warn about packages that
(if (lookup-updater package updaters) have no matching updater. PARTIAL-VERSION? is provided to the
(let ((version output source underlying `package-update' call; see its documentation for the
(package-update store package updaters details."
#:version version (match update-spec
#:key-download key-download (($ <update-spec> package version partial?)
#:key-server key-server)) (if (lookup-updater package updaters)
(loc (or (package-field-location package 'version) (let ((version output source
(package-location package)))) (package-update store package updaters
(when version #:version version
(if (and=> output file-exists?) #:partial-version? partial?
(begin #:key-download key-download
(info loc #:key-server key-server))
(G_ "~a: updating from version ~a to version ~a...~%") (loc (or (package-field-location package 'version)
(package-name package) (package-location package))))
(package-version package) version) (when version
(let ((hash (file-hash* output))) (if (and=> output file-exists?)
(update-package-source package source hash))) (begin
(warning (G_ "~a: version ~a could not be \ (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~%") downloaded and authenticated; not updating~%")
(package-name package) version)))) (package-name package) version))))
(when warn? (when warn?
(warn-no-updater package)))) (warn-no-updater package))))))
(define* (check-for-package-update update-spec updaters #:key warn?) (define* (check-for-package-update update-spec updaters #:key warn?)
"Check whether UPDATE-SPEC is feasible, and print a message. "Check whether UPDATE-SPEC is feasible, and print a message.
When WARN? is true and no updater exists for PACKAGE, print a warning." When WARN? is true and no updater exists for PACKAGE, print a warning."
(define package (match update-spec
(update-spec-package update-spec)) (($ <update-spec> package version partial?)
(match (package-latest-release package updaters
(match (package-latest-release package updaters #:version version
#:version #:partial-version? partial?)
(update-spec-version update-spec)) ((? upstream-source? source)
((? upstream-source? source) (let ((loc (or (package-field-location package 'version)
(let ((loc (or (package-field-location package 'version) (package-location package))))
(package-location package)))) (case (version-compare (upstream-source-version source)
(case (version-compare (upstream-source-version source) (package-version package))
(package-version package)) ((>)
((>) (info loc
(info loc (G_ "~a would be upgraded from ~a to ~a~%")
(G_ "~a would be upgraded from ~a to ~a~%") (package-name package) (package-version package)
(package-name package) (package-version package) (upstream-source-version source)))
(upstream-source-version source))) ((=)
((=) (when warn?
(when warn? (info loc
(info loc (G_ "~a is already the latest version of ~a~%")
(G_ "~a is already the latest version of ~a~%") (package-version package)
(package-version package) (package-name package))))
(package-name package)))) (else
(else (if version
(if (update-spec-version update-spec) (info loc
(info loc (G_ "~a would be downgraded from ~a to ~a~%")
(G_ "~a would be downgraded from ~a to ~a~%") (package-name package)
(package-name package) (package-version package)
(package-version package) (upstream-source-version source))
(upstream-source-version source)) (when warn?
(when warn? (warning loc
(warning loc (G_ "~a is greater than \
(G_ "~a is greater than \
the latest known version of ~a (~a)~%") the latest known version of ~a (~a)~%")
(package-version package) (package-version package)
(package-name package) (package-name package)
(upstream-source-version source)))))))) (upstream-source-version source))))))))
(#f (#f
(when warn? (when warn?
;; Distinguish between "no updater" and "failing updater." ;; Distinguish between "no updater" and "failing updater."
(match (lookup-updater package updaters) (match (lookup-updater package updaters)
((? upstream-updater? updater) ((? upstream-updater? updater)
(if (update-spec-version update-spec) (if version
(warning (G_ "'~a' updater failed to find version ~a of '~a'~%") (warning (G_ "'~a' updater failed to find version ~a of '~a'~%")
(upstream-updater-name updater) (upstream-updater-name updater)
(update-spec-version update-spec) version
(package-name package)) (package-name package))
(warning (package-location package) (warning (package-location package)
(G_ "'~a' updater failed to determine available \ (G_ "'~a' updater failed to determine available \
releases for ~a~%") releases for ~a~%")
(upstream-updater-name updater) (upstream-updater-name updater)
(package-name package)))) (package-name package))))
(#f (#f
(warn-no-updater package))))))) (warn-no-updater package)))))))))
;;; ;;;
@ -634,10 +643,9 @@ all are dependent packages: ~{~a~^ ~}~%")
(compose location-line (compose location-line
spec->location))))) spec->location)))))
(for-each (for-each
(lambda (update) (lambda (spec)
(update-package store (update-package store
(update-spec-package update) spec
(update-spec-version update)
updaters updaters
#:key-server (%openpgp-key-server) #:key-server (%openpgp-key-server)
#:key-download key-download #:key-download key-download

26
guix/upstream.scm
View file

@ -263,16 +263,17 @@ them matches."
(define* (package-latest-release package (define* (package-latest-release package
#:optional #:optional
(updaters (force %updaters)) (updaters (force %updaters))
#:key (version #f)) #:key version partial-version?)
"Return an upstream source to update PACKAGE, a <package> object, or #f if "Return an <upstream-source> object to update PACKAGE, a <package> object,
none of UPDATERS matches PACKAGE. When several updaters match PACKAGE, try or #f if none of UPDATERS matches PACKAGE. When several updaters match
them until one of them returns an upstream source. It is the caller's PACKAGE, try them until one of them returns an upstream source. It is the
responsibility to ensure that the returned source is newer than the current caller's responsibility to ensure that the returned source is newer than the
one." current one."
(any (match-lambda (any (match-lambda
(($ <upstream-updater> name description pred import) (($ <upstream-updater> name description pred import)
(and (pred package) (and (pred package)
(import package #:version version)))) (import package #:version version
#:partial-version? partial-version?))))
updaters)) updaters))
(define* (package-latest-release* package (define* (package-latest-release* package
@ -511,7 +512,7 @@ SOURCE, an <upstream-source>."
(define* (package-update store package (define* (package-update store package
#:optional (updaters (force %updaters)) #:optional (updaters (force %updaters))
#:key (version #f) #:key version partial-version?
(key-download 'auto) key-server) (key-download 'auto) key-server)
"Return the new version, the file name of the new version tarball, and input "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; changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date;
@ -520,8 +521,13 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'always', 'auto' (default), 'never', and 'interactive'. values: 'always', 'auto' (default), 'never', and 'interactive'.
When VERSION is specified, update PACKAGE to that version, even if that is a When VERSION is specified, update PACKAGE to that version, even if that is a
downgrade." downgrade. When PARTIAL-VERSION? is true, treat VERSION as having been only
(match (package-latest-release package updaters #:version version) 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) ((? upstream-source? source)
(if (or (version>? (upstream-source-version source) (if (or (version>? (upstream-source-version source)
(package-version package)) (package-version package))

22
tests/gem.scm
View file

@ -49,6 +49,25 @@
\"licenses\": [\"MIT\", \"Apache 2.0\"] \"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 (define test-foo-v2-json
"{ "{
\"name\": \"foo\", \"name\": \"foo\",
@ -273,6 +292,9 @@
("https://rubygems.org/api/v1/gems/foo.json" ("https://rubygems.org/api/v1/gems/foo.json"
(values (open-input-string test-foo-json) (values (open-input-string test-foo-json)
(string-length 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))))) (_ (error "Unexpected URL: " url)))))
(let ((source (package-latest-release (let ((source (package-latest-release
(dummy-package "ruby-foo" (dummy-package "ruby-foo"

65
tests/gnu-maintenance.scm
View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023-2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,6 +27,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module ((web client) #:select (current-http-proxy)) #:use-module ((web client) #:select (current-http-proxy))
#:use-module ((web uri) #:select (uri? uri->string))
#:use-module (ice-9 match)) #:use-module (ice-9 match))
(test-begin "gnu-maintenance") (test-begin "gnu-maintenance")
@ -157,11 +159,17 @@ submodules/qtbase-everywhere-src-6.5.2.tar.xz"
(rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\ (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")) submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
(test-equal "rewrite-url, without to-version" (define (mock-http-fetch/cached testcase)
"http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz" (lambda (url . rest)
(with-http-server (let* ((url (if (uri? url)
;; First reply, crawling http://dist.libuv.example.org/dist/. (uri->string url)
`((200 "\ 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> <!DOCTYPE html>
<html> <html>
<head><title>Index of dist</title></head> <head><title>Index of dist</title></head>
@ -174,8 +182,8 @@ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a> <a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
</body> </body>
</html>") </html>")
;; Second reply, crawling http://dist.libuv.example.org/dist/v1.46.0/.
(200 "\ (define libuv-dist-1.46.0-html "\
<!DOCTYPE html> <!DOCTYPE html>
<html> <html>
<head><title>Index of dist/v1.46.0</title></head> <head><title>Index of dist/v1.46.0</title></head>
@ -190,9 +198,44 @@ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\"> <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> libuv-v1.46.0.tar.gz.sign</a>
</body> </body>
</html>")) </html>")
(parameterize ((current-http-proxy (%local-url)))
(rewrite-url "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" (define libuv-dist-1.44.2-html "\
"1.45.0")))) <!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) (test-end)

10
tests/guix-refresh.sh
View file

@ -31,7 +31,8 @@ export GUIX_TEST_UPDATER_TARGETS
idutils_version="$(guix package -A ^idutils$ | cut -f2)" idutils_version="$(guix package -A ^idutils$ | cut -f2)"
GUIX_TEST_UPDATER_TARGETS=' GUIX_TEST_UPDATER_TARGETS='
(("guile" "3" (("12.5" "file:///dev/null") (("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"))) ("libreoffice" "" (("1.0" "file:///dev/null")))
("idutils" "" (("'$idutils_version'" "file:///dev/null"))) ("idutils" "" (("'$idutils_version'" "file:///dev/null")))
("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source" ("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;; *) false;;
esac 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@3=1.6.4" for spec in "guile=1.6.4" "guile@3=1.6.4"
do do
guix refresh -t test "$spec" guix refresh -t test "$spec"

4
tests/import-git.scm
View file

@ -22,6 +22,7 @@
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix import git) #:use-module (guix import git)
#:use-module ((guix import utils) #:select (find-version))
#:use-module (guix git-download) #:use-module (guix git-download)
#:use-module (guix tests git) #:use-module (guix tests git)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -45,6 +46,9 @@
(base32 (base32
"0000000000000000000000000000000000000000000000000000")))))) "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" (test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter"
"1.0.1" "1.0.1"
(with-temporary-git-repository directory (with-temporary-git-repository directory