[bug#38408] [PATCH 3/3] Rewrote some of guix/import/crate.scm to use recursive-import-semver and updated script and test.

[Martin Becze <mjbecze@riseup.net>]

[-- Attachment #1: Type: text/plain, Size: 12858 bytes --]

On 2019-11-28 00:16, Martin Becze wrote:
> * guix/import/crate.scm (make-crate-sexp): Use <crate> <crate-version> as args
> * guix/import/crate.scm (crate->crate-version): New Procedure
> * guix/import/crate.scm (crate->versions): New Procedure
> * guix/import/crate.scm (crate-recursive-import): Updated to user
> recursive-import-semver
> * guix/scripts/import/crate.scm (guix-import-crate): Remove
> `define-public` generation from UI
> * guix/tests/crate.scm: Updated tests
> ---
>  guix/import/crate.scm         | 165 ++++++++++++++++++----------------
>  guix/scripts/import/crate.scm |   9 +-
>  tests/crate.scm               |   2 +-
>  3 files changed, 91 insertions(+), 85 deletions(-)
> 
> diff --git a/guix/import/crate.scm b/guix/import/crate.scm
> index 8dc014d232..da92c43b8c 100644
> --- a/guix/import/crate.scm
> +++ b/guix/import/crate.scm
> @@ -38,6 +38,7 @@
>    #: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
>              crate-recursive-import
> @@ -85,7 +86,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
>  
> @@ -111,7 +112,9 @@ record or #f if it was not found."
>           (url  (string-append (%crate-base-url) path)))
>      (match (assoc-ref (or (json-fetch url) '()) "dependencies")
>        ((? vector? vector)
> -       (map json->crate-dependency (vector->list vector)))
> +       (filter (lambda (dep)
> +                 (not (eq? (crate-dependency-kind dep) 'dev)))
> +               (map json->crate-dependency (vector->list vector))))
>        (_
>         '()))))
>  
> @@ -141,62 +144,84 @@ record or #f if it was not found."
>      ((args ...)
>       `((arguments (,'quasiquote ,args))))))
>  
> -(define* (make-crate-sexp #:key name version cargo-inputs
> cargo-development-inputs
> -                          home-page synopsis description license
> -                          #:allow-other-keys)
> -  "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."
> -  (let* ((port (http-fetch (crate-uri name version)))
> +(define (make-crate-sexp crate version* dependencies)
> +  "Return the `package' s-expression for a rust package given <crate>,
> + <crate-version> and a list of <crate-dependency>"
> +  (define normal-dependency?
> +    (match-lambda ((_ dep) (not (eq? (crate-dependency-kind dep) 'dev)))))
> +
> +  (define (string->license string)
> +    (match (regexp-exec %dual-license-rx string)
> +      (#f (list (spdx-string->license string)))
> +      (m  (list (spdx-string->license (match:substring m 1))
> +                (spdx-string->license (match:substring m 2))))))
> +
> +  (let* ((dep-crates dev-dep-crates (partition normal-dependency?
> dependencies))
> +         (cargo-inputs (sort (unzip1 dep-crates)
> +                             string-ci<?))
> +         (cargo-development-inputs
> +          (sort (unzip1 dev-dep-crates)
> +                string-ci<?))
> +         (name (crate-name crate))
> +         (version (crate-version-number version*))
> +         (home-page (or (crate-home-page crate)
> +                        (crate-repository crate)))
> +         (synopsis (crate-description crate))
> +         (description (crate-description crate))
> +         (license (and=> (crate-version-license version*)
> +                         string->license))
> +         (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))
>           (pkg `(package
> -                   (name ,guix-name)
> -                   (version ,version)
> -                   (source (origin
> -                             (method url-fetch)
> -                             (uri (crate-uri ,name version))
> -                             (file-name (string-append name "-"
> version ".tar.gz"))
> -                             (sha256
> -                              (base32
> -                               ,(bytevector->nix-base32-string
> (port-sha256 port))))))
> -                   (build-system cargo-build-system)
> -                   ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
> -                                              (maybe-cargo-development-inputs
> -                                                cargo-development-inputs)))
> -                   (home-page ,(match home-page
> -                                 (() "")
> -                                 (_ home-page)))
> -                   (synopsis ,synopsis)
> -                   (description ,(beautify-description description))
> -                   (license ,(match license
> -                               (() #f)
> -                               ((license) license)
> -                               (_ `(list ,@license)))))))
> -         (close-port port)
> -         pkg))
> +                 (name ,guix-name)
> +                 (version ,version)
> +                 (source (origin
> +                           (method url-fetch)
> +                           (uri (crate-uri ,name version))
> +                           (file-name (string-append name "-" version
> ".crate"))
> +                           (sha256
> +                            (base32
> +                             ,(bytevector->nix-base32-string
> (port-sha256 port))))))
> +                 (build-system cargo-build-system)
> +                 ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
> +                                            (maybe-cargo-development-inputs
> +                                             cargo-development-inputs)))
> +                 (home-page ,(match home-page
> +                               (() "")
> +                               (_ home-page)))
> +                 (synopsis ,synopsis)
> +                 (description ,(beautify-description description))
> +                 (license ,(match license
> +                             (() #f)
> +                             ((license) license)
> +                             (_ `(list ,@license)))))))
> +
> +    (close-port port)
> +    pkg))
>  
>  (define %dual-license-rx
>    ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0".
>    ;; This regexp matches that.
>    (make-regexp "^(.*) OR (.*)$"))
>  
> +(define (crate->crate-version crate version-number)
> +  "returns the <crate-version> for a given CRATE and VERSION-NUMBER"
> +  (find (lambda (version)
> +            (string=? (crate-version-number version)
> +                      version-number))
> +          (crate-versions crate)))
> +
> +(define (crate->versions crate)
> +  "Returns a list of versions for a given CRATE"
> +  (map (lambda (version)
> +         (crate-version-number version))
> +       (crate-versions crate)))
> +
>  (define* (crate->guix-package crate-name #:optional version)
>    "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 (string->license string)
> -    (match (regexp-exec %dual-license-rx string)
> -      (#f (list (spdx-string->license string)))
> -      (m  (list (spdx-string->license (match:substring m 1))
> -                (spdx-string->license (match:substring m 2))))))
> -
> -  (define (normal-dependency? dependency)
> -    (eq? (crate-dependency-kind dependency) 'normal))
> -
>    (define crate
>      (lookup-crate crate-name))
>  
> @@ -205,38 +230,27 @@ latest version of CRATE-NAME."
>          (crate-latest-version crate)))
>  
>    (define version*
> -    (find (lambda (version)
> -            (string=? (crate-version-number version)
> -                      version-number))
> -          (crate-versions crate)))
> +    (crate->crate-version crate version-number))
>  
> -  (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<?)))
> -         (values
> -          (make-crate-sexp #:name crate-name
> -                           #:version (crate-version-number version*)
> -                           #:cargo-inputs cargo-inputs
> -                           #:cargo-development-inputs cargo-development-inputs
> -                           #:home-page (or (crate-home-page crate)
> -                                           (crate-repository crate))
> -                           #:synopsis (crate-description crate)
> -                           #:description (crate-description crate)
> -                           #:license (and=> (crate-version-license version*)
> -                                            string->license))
> -          (append cargo-inputs cargo-development-inputs)))))
> +  (define dependencies (map
> +                        (lambda (dep)
> +                          (list (crate-name->package-name
> +                           (crate-dependency-id dep)) dep))
> +                        (crate-version-dependencies version*)))
> +  (make-crate-sexp crate version* dependencies))
>  
> -(define (crate-recursive-import crate-name)
> -  (recursive-import crate-name #f
> -                    #:repo->guix-package (lambda (name repo)
> -                                           (crate->guix-package name))
> -                    #:guix-name crate-name->package-name))
> +(define* (crate-recursive-import name #:optional version)
> +  (recursive-import-semver
> +   #:name name
> +   #:version version
> +   #:name->metadata lookup-crate
> +   #:metadata->package crate->crate-version
> +   #:metadata-versions crate->versions
> +   #:package-dependencies crate-version-dependencies
> +   #:dependency-name crate-dependency-id
> +   #:dependency-range crate-dependency-requirement
> +   #:guix-name crate-name->package-name
> +   #:make-sexp make-crate-sexp))
>  
>  (define (guix-package->crate-name package)
>    "Return the crate name of PACKAGE."
> @@ -285,4 +299,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 4690cceb4d..85ae6fbe59 100644
> --- a/guix/scripts/import/crate.scm
> +++ b/guix/scripts/import/crate.scm
> @@ -96,14 +96,7 @@ 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))
> -                (reverse
> -                 (stream->list
> -                  (crate-recursive-import name))))
> +           (stream->list (crate-recursive-import name version))
>             (let ((sexp (crate->guix-package name version)))
>               (unless sexp
>                 (leave (G_ "failed to download meta-data for package '~a'~%")
> diff --git a/tests/crate.scm b/tests/crate.scm
> index c14862ad9f..b77cbb08c6 100644
> --- a/tests/crate.scm
> +++ b/tests/crate.scm
> @@ -95,7 +95,7 @@
>           ('source ('origin
>                      ('method 'url-fetch)
>                      ('uri ('crate-uri "foo" 'version))
> -                    ('file-name ('string-append 'name "-" 'version ".tar.gz"))
> +                    ('file-name ('string-append 'name "-" 'version ".crate"))
>                      ('sha256
>                       ('base32
>                        (? string? hash)))))

I'm added a patch that will skips the building of libraries which I
would assume most of the packages being imported are. This could be
parametrized in the future.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-added-skip-build-t-to-the-output-of-make-crate-sexp-.patch --]
[-- Type: text/x-diff; name=0001-added-skip-build-t-to-the-output-of-make-crate-sexp-.patch, Size: 1876 bytes --]

From 3f2ff3b4dc4cdf8b0282316b9c2426291da8a6c7 Mon Sep 17 00:00:00 2001
From: Martin Becze <mjbecze@riseup.net>
Date: Sat, 30 Nov 2019 11:27:05 -0500
Subject: [PATCH] added "#:skip-build? #t" to the output of (make-crate-sexp).
 Most the the packages imported will be libaries and won't need to build. The
 top level package will build them though.

* guix/import/crate.scm (make-crate-sexp): added "#:skip-build? #t" to the output
---
 guix/import/crate.scm | 3 ++-
 tests/crate.scm       | 3 ++-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index da92c43b8c..5683369b7a 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -183,7 +183,8 @@ record or #f if it was not found."
                             (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)))
                  (home-page ,(match home-page
diff --git a/tests/crate.scm b/tests/crate.scm
index b77cbb08c6..64e5b6932e 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -102,7 +102,8 @@
          ('build-system 'cargo-build-system)
          ('arguments
           ('quasiquote
-           ('#:cargo-inputs (("rust-bar" ('unquote rust-bar))))))
+           ('#:skip-build? #t
+            #:cargo-inputs (("rust-bar" ('unquote rust-bar))))))
          ('home-page "http://example.com")
          ('synopsis "summary")
          ('description "summary")
-- 
2.24.0