[bug#38408] [PATCH v9 2/8] guix: import: crate: Use semver to resovle module versions

[Martin Becze]

*  guix/import/crate.scm (make-crate-sexp): formatting, added '#:skip-build?'
   to build system args; added package definition geneation
*  guix/import/crate.scm (crate->guix-package): Use semver to resolve the
   correct module versions
*  tests/crate.scm: added version data to (recursuve-import) test
---
 guix/import/crate.scm         |  87 ++++++----
 guix/scripts/import/crate.scm |  11 +-
 tests/crate.scm               | 290 +++++++++++++++++++---------------
 3 files changed, 225 insertions(+), 163 deletions(-)

diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 57823c3639..84b152620c 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 David Craven <address@hidden>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <address@hidden>
-;;; Copyright © 2019 Martin Becze <address@hidden>
+;;; Copyright © 2019, 2020 Martin Becze <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,9 +35,12 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (json)
+  #:use-module (semver)
+  #:use-module (semver ranges)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:export (crate->guix-package
             guix-package->crate-name
             string->license
@@ -86,7 +89,7 @@
   crate-dependency?
   json->crate-dependency
   (id            crate-dependency-id "crate_id")  ;string
-  (kind          crate-dependency-kind "kind"     ;'normal | 'dev
+  (kind          crate-dependency-kind "kind"     ;'normal | 'dev | 'build
                  string->symbol)
   (requirement   crate-dependency-requirement "req")) ;string
 
@@ -150,9 +153,14 @@ VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, 
HOME-PAGE, SYNOPSIS, DESCRIPTIO
 and LICENSE."
   (let* ((port (http-fetch (crate-uri name version)))
          (guix-name (crate-name->package-name name))
-         (cargo-inputs (map crate-name->package-name cargo-inputs))
-         (cargo-development-inputs (map crate-name->package-name
-                                        cargo-development-inputs))
+         (cargo-inputs
+          (map
+           (lambda (name-version)
+             (apply crate-name->package-name name-version)) cargo-inputs))
+         (cargo-development-inputs
+          (map
+           (lambda (name-version)
+             (apply crate-name->package-name name-version)) 
cargo-development-inputs))
          (pkg `(package
                    (name ,guix-name)
                    (version ,version)
@@ -164,9 +172,10 @@ and LICENSE."
                               (base32
                                ,(bytevector->nix-base32-string (port-sha256 
port))))))
                    (build-system cargo-build-system)
-                   ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
+                   ,@(maybe-arguments (append '(#:skip-build? #t)
+                                              (maybe-cargo-inputs cargo-inputs)
                                               (maybe-cargo-development-inputs
-                                                cargo-development-inputs)))
+                                               cargo-development-inputs)))
                    (home-page ,(match home-page
                                  (() "")
                                  (_ home-page)))
@@ -177,7 +186,7 @@ and LICENSE."
                                ((license) license)
                                (_ `(list ,@license)))))))
          (close-port port)
-         pkg))
+         (package->definition pkg #t)))
 
 (define (string->license string)
   (filter-map (lambda (license)
@@ -188,14 +197,19 @@ and LICENSE."
                          'unknown-license!)))
               (string-split string (string->char-set " /"))))
 
-(define* (crate->guix-package crate-name #:optional version)
+(define* (crate->guix-package crate-name #:key version #: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, attempt to fetch that version; otherwise fetch the
 latest version of CRATE-NAME."
 
+  (define (semver-range-contains-string? range version)
+    (semver-range-contains? (string->semver-range range)
+                            (string->semver version)))
+
   (define (normal-dependency? dependency)
-    (eq? (crate-dependency-kind dependency) 'normal))
+    (or (eq? (crate-dependency-kind dependency) 'build)
+        (eq? (crate-dependency-kind dependency) 'normal)))
 
   (define crate
     (lookup-crate crate-name))
@@ -204,21 +218,36 @@ latest version of CRATE-NAME."
     (or version
         (crate-latest-version crate)))
 
-  (define version*
+  (define (find-version crate range)
+    "finds the a vesion of a crate that fulfils the semver <range>"
     (find (lambda (version)
-            (string=? (crate-version-number version)
-                      version-number))
+            (semver-range-contains-string?
+             range
+             (crate-version-number version)))
           (crate-versions crate)))
 
+  (define version*
+    (find-version crate version-number))
+
+  (define (sort-map-deps deps)
+    "sorts the dependencies and maps the dependencies to a list
+     containing pairs of (name version)"
+    (sort (map (lambda (dep)
+                 (let* ((name (crate-dependency-id dep))
+                        (crate (lookup-crate name))
+                        (req (crate-dependency-requirement dep))
+                        (ver (find-version crate req)))
+                   (list name
+                         (crate-version-number ver))))
+               deps)
+          (match-lambda* (((_ name) ...)
+                          (apply string-ci<? name)))))
+
   (and crate version*
-       (let* ((dependencies   (crate-version-dependencies version*))
-              (dep-crates     (filter normal-dependency? dependencies))
-              (dev-dep-crates (remove normal-dependency? dependencies))
-              (cargo-inputs   (sort (map crate-dependency-id dep-crates)
-                                    string-ci<?))
-              (cargo-development-inputs
-               (sort (map crate-dependency-id dev-dep-crates)
-                     string-ci<?)))
+       (let* ((dependencies (crate-version-dependencies version*))
+              (dep-crates dev-dep-crates (partition normal-dependency? 
dependencies))
+              (cargo-inputs (sort-map-deps dep-crates))
+              (cargo-development-inputs '()))
          (values
           (make-crate-sexp #:name crate-name
                            #:version (crate-version-number version*)
@@ -230,15 +259,12 @@ latest version of CRATE-NAME."
                            #:description (crate-description crate)
                            #:license (and=> (crate-version-license version*)
                                             string->license))
-          (append cargo-inputs cargo-development-inputs)))))
+          cargo-inputs))))
 
-(define* (crate-recursive-import crate-name #:optional version)
-  (recursive-import crate-name #f
-                    #:repo->guix-package
-                    (lambda (name repo)
-                      (let ((version (and (string=? name crate-name)
-                                          version)))
-                        (crate->guix-package name version)))
+(define* (crate-recursive-import crate-name #:key version)
+  (recursive-import crate-name
+                    #:repo->guix-package crate->guix-package
+                    #:version version
                     #:guix-name crate-name->package-name))
 
 (define (guix-package->crate-name package)
@@ -253,7 +279,7 @@ latest version of CRATE-NAME."
       ((name _ ...) name))))
 
 (define (crate-name->package-name name)
-  (string-append "rust-" (string-join (string-split name #\_) "-")))
+  (guix-name "rust-" name))
 
 
 ;;;
@@ -288,4 +314,3 @@ latest version of CRATE-NAME."
    (description "Updater for crates.io packages")
    (pred crate-package?)
    (latest latest-release)))
-
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index d834518c18..552628cfc7 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -2,7 +2,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <address@hidden>
 ;;; Copyright © 2016 David Craven <address@hidden>
-;;; Copyright © 2019 Martin Becze <address@hidden>
+;;; Copyright © 2019, 2020 Martin Becze <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -95,13 +95,8 @@ Import and convert the crate.io package for 
PACKAGE-NAME.\n"))
          (package-name->name+version spec))
 
        (if (assoc-ref opts 'recursive)
-           (map (match-lambda
-                  ((and ('package ('name name) . rest) pkg)
-                   `(define-public ,(string->symbol name)
-                      ,pkg))
-                  (_ #f))
-                (crate-recursive-import name version))
-           (let ((sexp (crate->guix-package name version)))
+           (crate-recursive-import name #:version version)
+           (let ((sexp (crate->guix-package name #:version version)))
              (unless sexp
                (leave (G_ "failed to download meta-data for package '~a'~%")
                       (if version
diff --git a/tests/crate.scm b/tests/crate.scm
index aa51faebf9..39561d5745 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014 David Thompson <address@hidden>
 ;;; Copyright © 2016 David Craven <address@hidden>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <address@hidden>
+;;; Copyright © 2020 Martin Becze <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,8 +55,9 @@
   "{
   \"dependencies\": [
      {
-       \"crate_id\": \"bar\",
+       \"crate_id\": \"leaf-alice\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      }
   ]
 }")
@@ -88,18 +90,22 @@
      {
        \"crate_id\": \"intermediate-1\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
      {
        \"crate_id\": \"intermediate-2\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      }
      {
        \"crate_id\": \"leaf-alice\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
      {
        \"crate_id\": \"leaf-bob\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
   ]
 }")
@@ -132,14 +138,17 @@
      {
        \"crate_id\": \"intermediate-2\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
      {
        \"crate_id\": \"leaf-alice\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
      {
        \"crate_id\": \"leaf-bob\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      }
   ]
 }")
@@ -172,6 +181,7 @@
      {
        \"crate_id\": \"leaf-bob\",
        \"kind\": \"normal\",
+       \"req\": \"1.0.0\",
      },
   ]
 }")
@@ -252,34 +262,48 @@
               (open-input-string test-foo-crate))
              ("https://crates.io/api/v1/crates/foo/1.0.0/download";
               (set! test-source-hash
-                (bytevector->nix-base32-string
-                 (sha256 (string->bytevector "empty file\n" "utf-8"))))
+                    (bytevector->nix-base32-string
+                     (sha256 (string->bytevector "empty file\n" "utf-8"))))
               (open-input-string "empty file\n"))
              ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies";
               (open-input-string test-foo-dependencies))
+             ("https://crates.io/api/v1/crates/leaf-alice";
+              (open-input-string test-leaf-alice-crate))
+             ("https://crates.io/api/v1/crates/leaf-alice/1.0.0/download";
+              (set! test-source-hash
+                    (bytevector->nix-base32-string
+                     (sha256 (string->bytevector "empty file\n" "utf-8"))))
+              (open-input-string "empty file\n"))
+             ("https://crates.io/api/v1/crates/leaf-alice/1.0.0/dependencies";
+              (open-input-string test-leaf-alice-dependencies))
              (_ (error "Unexpected URL: " url)))))
-    (match (crate->guix-package "foo")
-      (('package
-         ('name "rust-foo")
-         ('version "1.0.0")
-         ('source ('origin
-                    ('method 'url-fetch)
-                    ('uri ('crate-uri "foo" 'version))
-                    ('file-name ('string-append 'name "-" 'version ".tar.gz"))
-                    ('sha256
-                     ('base32
-                      (? string? hash)))))
-         ('build-system 'cargo-build-system)
-         ('arguments
-          ('quasiquote
-           ('#:cargo-inputs (("rust-bar" ('unquote rust-bar))))))
-         ('home-page "http://example.com";)
-         ('synopsis "summary")
-         ('description "summary")
-         ('license ('list 'license:expat 'license:asl2.0)))
-       (string=? test-source-hash hash))
-      (x
-       (pk 'fail x #f)))))
+
+        (match (crate->guix-package "foo")
+          ((define-public rust-foo-1.0.0
+             (package (name "rust-foo")
+                      (version "1.0.0")
+                      (source
+                       (origin
+                         (method url-fetch)
+                         (uri (crate-uri "foo" 'version))
+                         (file-name (string-append name "-" version ".tar.gz"))
+                         (sha256
+                          (base32
+                           (?  string? hash)))))
+                      (build-system 'cargo-build-system)
+                      (arguments
+                       ('quasiquote
+                        (#:skip-build? #t
+                         #:cargo-inputs
+                         (("rust-leaf-alice-1.0.0" ('unquote 
rust-leaf-alice-1.0.0))))))
+                      (home-page "http://example.com";)
+                      (synopsis "summary")
+                      (description "summary")
+                      (license (list license:expat license:asl2.0))))
+
+           (string=? test-source-hash hash))
+          (x
+           (pk 'fail x #f)))))
 
 (test-assert "cargo-recursive-import"
   ;; Replace network resources with sample data.
@@ -334,105 +358,123 @@
              (_ (error "Unexpected URL: " url)))))
         (match (crate-recursive-import "root")
           ;; rust-intermediate-2 has no dependency on the rust-leaf-alice 
package, so this is a valid ordering
-          ((('package
-              ('name "rust-leaf-alice")
-              ('version (? string? ver))
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('crate-uri "leaf-alice" '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)))
-            ('package
-              ('name "rust-leaf-bob")
-              ('version (? string? ver))
-              ('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)))
-            ('package
-              ('name "rust-intermediate-2")
-              ('version (? string? ver))
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('crate-uri "intermediate-2" '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))))))
-              ('home-page "http://example.com";)
-              ('synopsis "summary")
-              ('description "summary")
-              ('license ('list 'license:expat 'license:asl2.0)))
-            ('package
-              ('name "rust-intermediate-1")
-              ('version (? string? ver))
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('crate-uri "intermediate-1" 'version))
-                 ('file-name
-                  ('string-append 'name "-" 'version ".tar.gz"))
-                 ('sha256
-                  ('base32
-                   (? string? hash)))))
-              ('build-system 'cargo-build-system)
-              ('arguments
-               ('quasiquote
-                ('#:cargo-inputs (("rust-intermediate-2" ('unquote 
rust-intermediate-2))
-                                  ("rust-leaf-alice" ('unquote 
rust-leaf-alice))
-                                  ("rust-leaf-bob" ('unquote 
rust-leaf-bob))))))
-              ('home-page "http://example.com";)
-              ('synopsis "summary")
-              ('description "summary")
-              ('license ('list 'license:expat 'license:asl2.0)))
-            ('package
-              ('name "rust-root")
-              ('version (? string? ver))
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('crate-uri "root" 'version))
-                 ('file-name
-                  ('string-append 'name "-" 'version ".tar.gz"))
-                 ('sha256
-                  ('base32
-                   (? string? hash)))))
-              ('build-system 'cargo-build-system)
-              ('arguments
-               ('quasiquote
-                ('#:cargo-inputs (("rust-intermediate-1" ('unquote 
rust-intermediate-1))
-                                  ("rust-intermediate-2" ('unquote 
rust-intermediate-2))
-                                  ("rust-leaf-alice" ('unquote 
rust-leaf-alice))
-                                  ("rust-leaf-bob" ('unquote 
rust-leaf-bob))))))
-              ('home-page "http://example.com";)
-              ('synopsis "summary")
-              ('description "summary")
-              ('license ('list 'license:expat 'license:asl2.0))))
+          (((define-public rust-leaf-alice-1.0.0
+              (package
+                (name "rust-leaf-alice")
+                (version (?  string? ver))
+                (source
+                 (origin
+                   (method url-fetch)
+                   (uri (crate-uri "leaf-alice" version))
+                   (file-name
+                    (string-append name "-" version ".tar.gz"))
+                   (sha256
+                    (base32
+                     (?  string? hash)))))
+                (build-system cargo-build-system)
+                (arguments ('quasiquote (#:skip-build? #t)))
+                (home-page "http://example.com";)
+                (synopsis "summary")
+                (description "summary")
+                (license (list license:expat license:asl2.0))))
+            (define-public rust-leaf-bob-1.0.0
+              (package
+                (name "rust-leaf-bob")
+                (version (?  string? ver))
+                (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)
+                (arguments ('quasiquote (#:skip-build? #t)))
+                (home-page "http://example.com";)
+                (synopsis "summary")
+                (description "summary")
+                (license (list license:expat license:asl2.0))))
+            (define-public rust-intermediate-2-1.0.0
+              (package
+                (name "rust-intermediate-2")
+                (version (?  string? ver))
+                (source
+                 (origin
+                   (method url-fetch)
+                   (uri (crate-uri "intermediate-2" version))
+                   (file-name
+                    (string-append name "-" version ".tar.gz"))
+                   (sha256
+                    (base32
+                     (?  string? hash)))))
+                (build-system cargo-build-system)
+                (arguments
+                 ('quasiquote (#:skip-build? #t
+                               #:cargo-inputs
+                               (("rust-leaf-bob-1.0.0"
+                                 ('unquote rust-leaf-bob-1.0.0))))))
+                (home-page "http://example.com";)
+                (synopsis "summary")
+                (description "summary")
+                (license (list license:expat license:asl2.0))))
+            (define-public rust-intermediate-1-1.0.0
+              (package
+                (name "rust-intermediate-1")
+                (version (?  string? ver))
+                (source
+                 (origin
+                   (method url-fetch)
+                   (uri (crate-uri "intermediate-1" version))
+                   (file-name
+                    (string-append name "-" version ".tar.gz"))
+                   (sha256
+                    (base32
+                     (?  string? hash)))))
+                (build-system cargo-build-system)
+                (arguments
+                 ('quasiquote (#:skip-build? #t
+                               #:cargo-inputs
+                               (("rust-intermediate-2-1.0.0"
+                                 ,rust-intermediate-2-1.0.0)
+                                ("rust-leaf-alice-1.0.0"
+                                 ('unquote rust-leaf-alice-1.0.0))
+                                ("rust-leaf-bob-1.0.0"
+                                 ('unquote rust-leaf-bob-1.0.0))))))
+                (home-page "http://example.com";)
+                (synopsis "summary")
+                (description "summary")
+                (license (list license:expat license:asl2.0))))
+            (define-public rust-root-1.0.0
+              (package
+                (name "rust-root")
+                (version (?  string? ver))
+                (source
+                 (origin
+                   (method url-fetch)
+                   (uri (crate-uri "root" version))
+                   (file-name
+                    (string-append name "-" version ".tar.gz"))
+                   (sha256
+                    (base32
+                     (?  string? hash)))))
+                (build-system cargo-build-system)
+                (arguments
+                 ('quasiquote (#:skip-build?
+                               #t #:cargo-inputs
+                               (("rust-intermediate-1-1.0.0"
+                                 ('unquote rust-intermediate-1-1.0.0))
+                                ("rust-intermediate-2-1.0.0"
+                                 ('unquote rust-intermediate-2-1.0.0))
+                                ("rust-leaf-alice-1.0.0"
+                                 ('unquote rust-leaf-alice-1.0.0))
+                                ("rust-leaf-bob-1.0.0"
+                                 ('unquote rust-leaf-bob-1.0.0))))))
+                (home-page "http://example.com";)
+                (synopsis "summary")
+                (description "summary")
+                (license (list license:expat license:asl2.0)))))
            #t)
           (x
            (pk 'fail x #f)))))
-- 
2.25.0