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

1 files changed, 104 insertions, 35 deletions

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 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?
-                              #: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 <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)))
+                         (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 @@ 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))