From b26926189e5bf253093050f9a73f2d9d7555cc3e Mon Sep 17 00:00:00 2001 From: David Elsing Date: Thu, 21 Dec 2023 22:01:52 +0000 Subject: [PATCH] guix: import: Optionally import necessary yanked crates. * doc/guix.texi (Invoking guix import): Mention '--allow-yanked'. * guix/import/crate.scm (make-crate-sexp): Add yanked? argument. For yanked packages, use the full version suffixed by "-yanked" for generated variable names and add a comment and package property. (crate->guix-package): Add allow-yanked? argument and if it is set to #t, allow importing yanked crates if no other version matching the requirements exists. [find-package-version]: Packages previously marked as yanked are only included if allow-yanked? is #t and then take the lowest priority. [find-crate-version]: If allow-yanked? is #t, also consider yanked versions with the lowest priority. [dependency-name+version]: Rename to ... [dependency-name+version+yanked] ...this. Honor allow-yanked? and choose between an existing package and an upstream package. Exit with an error message if no version fulfilling the requirement is found. [version*]: Exit with an error message if the crate version is not found. (cargo-recursive-import): Add allow-yanked? argument. * guix/read-print.scm: Export . * guix/scripts/import/crate.scm: Add "--allow-yanked". * tests/crate.scm: Add test 'crate-recursive-import-only-yanked-available'. [sort-map-dependencies]: Adjust accordingly. [remove-yanked-info]: New variable. Adjust test 'crate-recursive-import-honors-existing-packages'. (test-bar-dependencies): Add yanked dev-dependencies. (test-leaf-bob-crate): Add yanked versions. (rust-leaf-bob-3.0.2-yanked): New variable. Signed-off-by: Efraim Flashner Change-Id: I175d89b39774e6b57dcd1f05bf68718d23866bb7 --- doc/guix.texi | 3 + guix/import/crate.scm | 137 ++++++++++++++++++------ guix/read-print.scm | 1 + guix/scripts/import/crate.scm | 14 ++- tests/crate.scm | 193 +++++++++++++++++++++++++++++++++- 5 files changed, 309 insertions(+), 39 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 544f86a6ac..395545bed7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14589,6 +14589,9 @@ in Guix. If @option{--recursive-dev-dependencies} is specified, also the recursively imported packages contain their development dependencies, which are recursively imported as well. +@item --allow-yanked +If no non-yanked version of a crate is available, use the latest yanked +version instead instead of aborting. @end table @item elm diff --git a/guix/import/crate.scm b/guix/import/crate.scm index db5461312f..c57bd0bc6a 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -26,12 +26,15 @@ (define-module (guix import crate) #:use-module (guix base32) #:use-module (guix build-system cargo) + #:use-module (guix diagnostics) #:use-module (gcrypt hash) #:use-module (guix http-client) + #:use-module (guix i18n) #:use-module (guix import json) #:use-module (guix import utils) #:use-module (guix memoization) #:use-module (guix packages) + #:use-module (guix read-print) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (gnu packages) @@ -41,6 +44,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-69) #:use-module (srfi srfi-71) #:export (crate->guix-package guix-package->crate-name @@ -100,7 +104,7 @@ ;; Autoload Guile-Semver so we only have a soft dependency. (module-autoload! (current-module) - '(semver) '(string->semver semver->string semversemver semver->string semversemver-range semver-range-contains?)) @@ -165,16 +169,18 @@ record or #f if it was not found." (list-matches "^(0+\\.){,2}[0-9]+" version)))) (define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs - home-page synopsis description license build?) + home-page synopsis description license build? yanked?) "Return the `package' s-expression for a rust package with the given NAME, VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (format-inputs inputs) (map (match-lambda - ((name version) + ((name version yanked) (list (crate-name->package-name name) - (version->semver-prefix version)))) + (if yanked + (string-append version "-yanked") + (version->semver-prefix version))))) inputs)) (let* ((port (http-fetch (crate-uri name version))) @@ -184,6 +190,9 @@ and LICENSE." (pkg `(package (name ,guix-name) (version ,version) + ,@(if yanked? + `(,(comment "; This version was yanked!\n" #t)) + '()) (source (origin (method url-fetch) (uri (crate-uri ,name version)) @@ -191,6 +200,9 @@ and LICENSE." (sha256 (base32 ,(bytevector->nix-base32-string (port-sha256 port)))))) + ,@(if yanked? + `((properties '((crate-version-yanked? . #t)))) + '()) (build-system cargo-build-system) ,@(maybe-arguments (append (if build? '() @@ -207,7 +219,10 @@ and LICENSE." ((license) license) (_ `(list ,@license))))))) (close-port port) - (package->definition pkg (version->semver-prefix version)))) + (package->definition pkg + (if yanked? + (string-append version "-yanked") + (version->semver-prefix version))))) (define (string->license string) (filter-map (lambda (license) @@ -218,13 +233,14 @@ and LICENSE." 'unknown-license!))) (string-split string (string->char-set " /")))) -(define* (crate->guix-package crate-name #:key version include-dev-deps? - #:allow-other-keys) +(define* (crate->guix-package + crate-name + #:key version include-dev-deps? allow-yanked? #:allow-other-keys) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure. When VERSION is specified, convert it into a semver range and attempt to fetch the latest version matching this semver range; otherwise fetch the latest -version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also +version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also look up the development dependencs for the given crate." (define (semver-range-contains-string? range version) @@ -243,63 +259,112 @@ look up the development dependencs for the given crate." (or version (crate-latest-version crate)))) - ;; find the highest existing package that fulfills the semver + ;; Find the highest existing package that fulfills the semver . + ;; Packages previously marked as yanked take lower priority. (define (find-package-version name range) (let* ((semver-range (string->semver-range range)) - (versions + (package-versions (sort - (filter (lambda (version) - (semver-range-contains? semver-range version)) + (filter (match-lambda ((semver yanked) + (and + (or allow-yanked? (not yanked)) + (semver-range-contains? semver-range semver)))) (map (lambda (pkg) - (string->semver (package-version pkg))) + (let ((version (package-version pkg))) + (list + (string->semver version) + (assoc-ref (package-properties pkg) + 'crate-version-yanked?)))) (find-packages-by-name (crate-name->package-name name)))) - semverstring (last versions))))) + (match-lambda* (((semver1 yanked1) (semver2 yanked2)) + (or (and yanked1 (not yanked2)) + (and (eq? yanked1 yanked2) + (semverstring semver) yanked))))) - ;; Find the highest version of a crate that fulfills the semver - ;; and hasn't been yanked. + ;; Find the highest version of a crate that fulfills the semver . + ;; If no matching non-yanked version has been found and allow-yanked? is #t, + ;; also consider yanked packages. (define (find-crate-version crate range) (let* ((semver-range (string->semver-range range)) (versions (sort (filter (lambda (entry) (and - (not (crate-version-yanked? (second entry))) + (or allow-yanked? + (not (crate-version-yanked? (second entry)))) (semver-range-contains? semver-range (first entry)))) (map (lambda (ver) (list (string->semver (crate-version-number ver)) ver)) (crate-versions crate))) - (match-lambda* (((semver _) ...) - (apply semversemver (first existing-version)) + (string->semver (crate-version-number ver))) + (begin + (warning (G_ "~A: version ~a is no longer yanked~%") + name (first existing-version)) + (cons name existing-version)) + (list name + (crate-version-number ver) + (crate-version-yanked? ver))) + (begin + (warning (G_ "~A: using existing version ~a, which was yanked~%") + name (first existing-version)) + (cons name existing-version))) + (begin + (unless ver + (leave (G_ "~A: no version found for requirement ~a~%") name req)) + (if (crate-version-yanked? ver) + (warning (G_ "~A: imported version ~a was yanked~%") + name (crate-version-number ver))) + (list name + (crate-version-number ver) + (crate-version-yanked? ver)))))))) (define version* (and crate - (find-crate-version crate version-number))) + (or (find-crate-version crate version-number) + (leave (G_ "~A: version ~a not found~%") crate-name version-number)))) ;; sort and map the dependencies to a list containing ;; pairs of (name version) (define (sort-map-dependencies deps) - (sort (map dependency-name+version + (sort (map dependency-name+version+yanked deps) - (match-lambda* (((name _) ...) + (match-lambda* (((name _ _) ...) (apply string-ci (crate-version-license version*) string->license)) - (append cargo-inputs cargo-development-inputs))) + (append + (remove-yanked-info cargo-inputs) + (remove-yanked-info cargo-development-inputs)))) (values #f '()))) (define* (crate-recursive-import - crate-name #:key version recursive-dev-dependencies?) + crate-name #:key version recursive-dev-dependencies? allow-yanked?) (recursive-import crate-name #:repo->guix-package @@ -340,7 +408,8 @@ look up the development dependencs for the given crate." (or (equal? (car params) crate-name) recursive-dev-dependencies?))) (apply crate->guix-package* - (append params `(#:include-dev-deps? ,include-dev-deps?)))))) + (append params `(#:include-dev-deps? ,include-dev-deps? + #:allow-yanked? ,allow-yanked?)))))) #:version version #:guix-name crate-name->package-name)) diff --git a/guix/read-print.scm b/guix/read-print.scm index 690f5dacdd..6421b79737 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -46,6 +46,7 @@ page-break page-break? + comment comment? comment->string diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index b13b6636a6..082a973aee 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -51,6 +51,10 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (display (G_ " --recursive-dev-dependencies include dev-dependencies recursively")) + (display (G_ " + --allow-yanked + allow importing yanked crates if no alternative + satisfying the version requirement exists")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -74,6 +78,9 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (option '("recursive-dev-dependencies") #f #f (lambda (opt name arg result) (alist-cons 'recursive-dev-dependencies #t result))) + (option '("allow-yanked") #f #f + (lambda (opt name arg result) + (alist-cons 'allow-yanked #t result))) %standard-import-options)) @@ -102,8 +109,11 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (crate-recursive-import name #:version version #:recursive-dev-dependencies? - (assoc-ref opts 'recursive-dev-dependencies)) - (crate->guix-package name #:version version #:include-dev-deps? #t)) + (assoc-ref opts 'recursive-dev-dependencies) + #:allow-yanked? (assoc-ref opts 'allow-yanked)) + (crate->guix-package + name #:version version #:include-dev-deps? #t + #:allow-yanked? (assoc-ref opts 'allow-yanked))) ((or #f '()) (leave (G_ "failed to download meta-data for package '~a'~%") (if version diff --git a/tests/crate.scm b/tests/crate.scm index e779f738b3..ce2f08aade 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -28,6 +28,7 @@ #:use-module ((gcrypt hash) #:select ((sha256 . gcrypt-sha256))) #:use-module (guix packages) + #:use-module (guix read-print) #:use-module (guix tests) #:use-module (gnu packages) #:use-module (ice-9 iconv) @@ -42,6 +43,8 @@ ;; leaf-alice 0.7.5 ;; bar-1.0.0 ;; leaf-bob 3.0.1 +;; leaf-bob 3.0.2 (dev-dependency) +;; leaf-bob 4.0.0 (dev-dependency) ;; ;; root-1.0.0 ;; root-1.0.4 @@ -68,6 +71,8 @@ ;; leaf-alice-0.7.5 ;; ;; leaf-bob-3.0.1 +;; leaf-bob-3.0.2 (yanked) +;; leaf-bob-4.0.0 (yanked) (define test-foo-crate @@ -150,6 +155,16 @@ \"crate_id\": \"leaf-bob\", \"kind\": \"normal\", \"req\": \"3.0.1\" + }, + { + \"crate_id\": \"leaf-bob\", + \"kind\": \"dev\", + \"req\": \"^3.0.2\" + }, + { + \"crate_id\": \"leaf-bob\", + \"kind\": \"dev\", + \"req\": \"^4.0.0\" } ] }") @@ -398,6 +413,22 @@ \"dependencies\": \"/api/v1/crates/leaf-bob/3.0.1/dependencies\" }, \"yanked\": false + }, + { \"id\": 234281, + \"num\": \"3.0.2\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/leaf-bob/3.0.2/dependencies\" + }, + \"yanked\": true + }, + { \"id\": 234282, + \"num\": \"4.0.0\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/leaf-bob/4.0.0/dependencies\" + }, + \"yanked\": true } ] } @@ -863,6 +894,18 @@ (description #f) (license #f))) +(define rust-leaf-bob-3.0.2-yanked + (package + (name "rust-leaf-bob") + (version "3.0.2") + (source #f) + (properties '((crate-version-yanked? . #t))) + (build-system #f) + (home-page #f) + (synopsis #f) + (description #f) + (license #f))) + (unless have-guile-semver? (test-skip 1)) (test-assert "crate-recursive-import-honors-existing-packages" (mock @@ -870,7 +913,7 @@ (lambda* (name #:optional version) (match name ("rust-leaf-bob" - (list rust-leaf-bob-3)) + (list rust-leaf-bob-3 rust-leaf-bob-3.0.2-yanked)) (_ '())))) (mock ((guix http-client) http-fetch @@ -894,8 +937,16 @@ (open-input-string "empty file\n")) ("https://crates.io/api/v1/crates/leaf-bob/3.0.2/dependencies" (open-input-string test-leaf-bob-dependencies)) + ("https://crates.io/api/v1/crates/leaf-bob/4.0.0/download" + (set! test-source-hash + (bytevector->nix-base32-string + (gcrypt-sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/leaf-bob/4.0.0/dependencies" + (open-input-string test-leaf-bob-dependencies)) (_ (error "Unexpected URL: " url))))) - (match (crate-recursive-import "bar") + (match (crate-recursive-import "bar" + #:allow-yanked? #t) (((define-public 'rust-bar-1 (package (name "rust-bar") @@ -913,7 +964,12 @@ (arguments ('quasiquote (#:cargo-inputs (("rust-leaf-bob" - ('unquote 'rust-leaf-bob-3)))))) + ('unquote 'rust-leaf-bob-3))) + #:cargo-development-inputs + (("rust-leaf-bob" + ('unquote 'rust-leaf-bob-3.0.2-yanked)) + ("rust-leaf-bob" + ('unquote 'rust-leaf-bob-4.0.0-yanked)))))) (home-page "http://example.com") (synopsis "summary") (description "summary") @@ -922,4 +978,135 @@ (x (pk 'fail x #f)))))) +(unless have-guile-semver? (test-skip 1)) +(test-assert "crate-import-only-yanked-available" + (mock + ((guix http-client) http-fetch + (lambda (url . rest) + (match url + ("https://crates.io/api/v1/crates/bar" + (open-input-string test-bar-crate)) + ("https://crates.io/api/v1/crates/bar/1.0.0/download" + (set! test-source-hash + (bytevector->nix-base32-string + (gcrypt-sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/bar/1.0.0/dependencies" + (open-input-string test-bar-dependencies)) + ("https://crates.io/api/v1/crates/leaf-bob" + (open-input-string test-leaf-bob-crate)) + ("https://crates.io/api/v1/crates/leaf-bob/3.0.1/download" + (set! test-source-hash + (bytevector->nix-base32-string + (gcrypt-sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/leaf-bob/3.0.1/dependencies" + (open-input-string test-leaf-bob-dependencies)) + ("https://crates.io/api/v1/crates/leaf-bob/3.0.2/download" + (set! test-source-hash + (bytevector->nix-base32-string + (gcrypt-sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/leaf-bob/3.0.2/dependencies" + (open-input-string test-leaf-bob-dependencies)) + ("https://crates.io/api/v1/crates/leaf-bob/4.0.0/download" + (set! test-source-hash + (bytevector->nix-base32-string + (gcrypt-sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/leaf-bob/4.0.0/dependencies" + (open-input-string test-leaf-bob-dependencies)) + (_ (error "Unexpected URL: " url))))) + (match (crate-recursive-import "bar" + #:recursive-dev-dependencies? #t + #:allow-yanked? #t) + (((define-public 'rust-leaf-bob-4.0.0-yanked + (package + (name "rust-leaf-bob") + (version "4.0.0") + ($ "; This version was yanked!\n" #t) + (source + (origin + (method url-fetch) + (uri (crate-uri "leaf-bob" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (properties ('quote (('crate-version-yanked? . #t)))) + (build-system cargo-build-system) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-leaf-bob-3.0.2-yanked + (package + (name "rust-leaf-bob") + (version "3.0.2") + ($ "; This version was yanked!\n" #t) + (source + (origin + (method url-fetch) + (uri (crate-uri "leaf-bob" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (properties ('quote (('crate-version-yanked? . #t)))) + (build-system cargo-build-system) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-leaf-bob-3 + (package + (name "rust-leaf-bob") + (version "3.0.1") + (source + (origin + (method url-fetch) + (uri (crate-uri "leaf-bob" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-bar-1 + (package + (name "rust-bar") + (version "1.0.0") + (source + (origin + (method url-fetch) + (uri (crate-uri "bar" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments + ('quasiquote (#:cargo-inputs + (("rust-leaf-bob" + ('unquote 'rust-leaf-bob-3))) + #:cargo-development-inputs + (("rust-leaf-bob" + ('unquote 'rust-leaf-bob-3.0.2-yanked)) + ("rust-leaf-bob" + ('unquote 'rust-leaf-bob-4.0.0-yanked)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0))))) + #t) + (x + (pk 'fail (pretty-print-with-comments (current-output-port) x) #f))))) + (test-end "crate")