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

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

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 semver<?))
+		  '(semver) '(string->semver semver->string semver<? semver=?))
 (module-autoload! (current-module)
 		  '(semver ranges) '(string->semver-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?
+(define* (crate->guix-package
-                              #:allow-other-keys)
+          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 <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)
+             (filter (match-lambda ((semver yanked)
-                       (semver-range-contains? semver-range version))
+                                    (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<?)))
+             (match-lambda* (((semver1 yanked1) (semver2 yanked2))
-      (and (not (null-list? versions))
+                             (or (and yanked1 (not yanked2))
-           (semver->string (last versions)))))
+                                 (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>
+  ;; Find the highest version of a crate that fulfills the semver <range>.
-  ;; and hasn't been yanked.
+  ;; 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 _) ...)
+             (match-lambda* (((semver ver) ...)
-                             (apply semver<? semver))))))
+                             (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))
+                 (req (crate-dependency-requirement dep))
-           (existing-version (find-package-version name req)))
+                 (existing-version (find-package-version name req)))
-      (if existing-version
+      (if (and existing-version (not (second existing-version)))
-          (list name existing-version)
+          (cons name existing-version)
           (let* ((crate (lookup-crate* name))
                  (ver (find-crate-version crate req)))
-            (list name
+            (if existing-version
-                  (crate-version-number ver))))))
+                (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 @@ look up the development dependencs for the given crate."
                                            '())))
         (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 @@ look up the development dependencs for the given crate."
                           #: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 @@ 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))
 

guix/read-print.scm

@@ -46,6 +46,7 @@
             page-break
             page-break?
 
+            <comment>
             comment
             comment?
             comment->string

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))
+                   (assoc-ref opts 'recursive-dev-dependencies)
-                  (crate->guix-package name #:version version #:include-dev-deps? #t))
+                   #: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

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")
+                ($ <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")