@@ -14516,6 +14516,9 @@ in Guix.
If @option{--recursive} 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
@@ -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,8 +233,9 @@ (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
@@ -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)))))
-
- ;; Find the highest version of a crate that fulfills the semver <range>
- ;; and hasn't been yanked.
+ (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>. 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)))
- (semver-range-contains? semver-range (first 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))
@@ -46,6 +46,7 @@ (define-module (guix read-print)
page-break
page-break?
+ <comment>
comment
comment?
comment->string
@@ -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
@@ -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")