ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-23 21:17:11 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix: import: Optionally import necessary yanked crates.

Browse source 
* 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 <comment>.
* 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 <efraim@flashner.co.il>
Change-Id: I175d89b39774e6b57dcd1f05bf68718d23866bb7
This commit is contained in:
David Elsing 2023-12-21 22:01:52 +00:00 committed by Efraim Flashner
parent 53add91be6
commit b26926189e
No known key found for this signature in database
GPG key ID: 41AAE7DCCA3D8351
5 changed files with 309 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
doc/guix.texi
View file

@ -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

137
guix/import/crate.scm
View file

@ -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 @@ (define-module (guix import crate)
#: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 @@ (define-json-mapping <crate-dependency> make-crate-dependency
;; Autoload Guile-Semver so we only have a soft dependency.
(module-autoload! (current-module)
'(semver) '(string->semver semver->string semver<?))
'(semver) '(string->semver semver->string semver<? semver=?))
(module-autoload! (current-module)
'(semver ranges) '(string->semver-range semver-range-contains?))
@ -165,16 +169,18 @@ (define (version->semver-prefix version)
(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 @@ (define (format-inputs inputs)
(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 @@ (define (format-inputs inputs)
(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 @@ (define (format-inputs inputs)
((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 @@ (define (string->license string)
'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 @@ (define version-number
(or version
(crate-latest-version crate))))
;; find the highest existing package that fulfills the semver <range>
;; Find the highest existing package that fulfills the semver <range>.
;; 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))))
semver<?)))
(and (not (null-list? versions))
(semver->string (last versions)))))
(match-lambda* (((semver1 yanked1) (semver2 yanked2))
(or (and yanked1 (not yanked2))
(and (eq? yanked1 yanked2)
(semver<? semver1 semver2))))))))
(and (not (null-list? package-versions))
(match-let (((semver yanked) (last package-versions)))
(list (semver->string semver) yanked)))))
;; Find the highest version of a crate that fulfills the semver <range>
;; and hasn't been yanked.
;; Find the highest version of a crate that fulfills the semver <range>.
;; 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 semver<? semver))))))
(match-lambda* (((semver ver) ...)
(match-let (((yanked1 yanked2)
(map crate-version-yanked? ver)))
(or (and yanked1 (not yanked2))
(and (eq? yanked1 yanked2)
(apply semver<? semver)))))))))
(and (not (null-list? versions))
(second (last versions)))))
(define (dependency-name+version dep)
;; If no non-yanked existing package version was found, check the upstream
;; versions. If a non-yanked upsteam version exists, use it instead,
;; otherwise use the existing package version, provided it exists.
(define (dependency-name+version+yanked dep)
(let* ((name (crate-dependency-id dep))
(req (crate-dependency-requirement dep))
(existing-version (find-package-version name req)))
(if existing-version
(list name existing-version)
(req (crate-dependency-requirement dep))
(existing-version (find-package-version name req)))
(if (and existing-version (not (second existing-version)))
(cons name existing-version)
(let* ((crate (lookup-crate* name))
(ver (find-crate-version crate req)))
(list name
(crate-version-number ver))))))
(if existing-version
(if (and ver (not (crate-version-yanked? ver)))
(if (semver=? (string->semver (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<? name)))))
(define (remove-yanked-info deps)
(map
(match-lambda ((name version yanked)
(list name version)))
deps))
(if (and crate version*)
(let* ((dependencies (crate-version-dependencies version*))
(dep-crates dev-dep-crates (partition normal-dependency? dependencies))
@ -309,6 +374,7 @@ (define (sort-map-dependencies deps)
'())))
(values
(make-crate-sexp #:build? include-dev-deps?
#:yanked? (crate-version-yanked? version*)
#:name crate-name
#:version (crate-version-number version*)
#:cargo-inputs cargo-inputs
@ -325,11 +391,13 @@ (define (sort-map-dependencies deps)
#:description (crate-description crate)
#:license (and=> (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 @@ (define* (crate-recursive-import
(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))

1
guix/read-print.scm
View file

@ -46,6 +46,7 @@ (define-module (guix read-print)
page-break
page-break?
<comment>
comment
comment?
comment->string

14
guix/scripts/import/crate.scm
View file

@ -51,6 +51,10 @@ (define (show-help)
(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 @@ (define %options
(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 @@ (define-values (name version)
(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

193
tests/crate.scm
View file

@ -28,6 +28,7 @@ (define-module (test-crate)
#: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 @@ (define-module (test-crate)
;; 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 @@ (define-module (test-crate)
;; 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 @@ (define test-bar-dependencies
\"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 @@ (define test-leaf-bob-crate
\"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 @@ (define rust-leaf-bob-3
(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 @@ (define rust-leaf-bob-3
(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 @@ (define rust-leaf-bob-3
(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 @@ (define rust-leaf-bob-3
(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 @@ (define rust-leaf-bob-3
(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")
($ <comment> "; 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")
($ <comment> "; 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")