[bug#35813] Add crate-recursive-import.
diff mbox series

Message ID CAAc=MEyL1Fp_qHrEUVFn207D_3NABCAOxPtq8ezc9mDaS3wo9A@mail.gmail.com
State New
Headers show
Series
  • [bug#35813] Add crate-recursive-import.
Related show

Commit Message

Brian Leung Aug. 5, 2019, 5:50 p.m. UTC
I took Karl's changes and updated them accordingly. I've also added a small
test. The patch containing his importer, my changes, and my test is
attached (the commit was made using my name--not sure if I should instead
apply Karl's patch).

Patch
diff mbox series

From 407959e97656803981ebf69f83b96a0be2ff6cb7 Mon Sep 17 00:00:00 2001
From: Brian Leung <bkleung89@gmail.com>
Date: Sat, 20 Jul 2019 21:35:14 +0200
Subject: [PATCH] gnu: Add crate-recursive-import.

* guix/import/crate.scm (crate-recursive-import): New variable.
* guix/script/import/crate.scm: Add recursive option.
* guix/tests/crate.scm (crate-recursive-import): New test.
---
---
 guix/import/crate.scm         | 31 ++++++++----
 guix/scripts/import/crate.scm | 28 +++++++++--
 tests/crate.scm               | 92 +++++++++++++++++++++++++++++++++--
 3 files changed, 132 insertions(+), 19 deletions(-)

diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 52c5cb1c30..51f55ea708 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -36,6 +36,7 @@ 
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
   #:export (crate->guix-package
+            crate-recursive-import
             guix-package->crate-name
             %crate-updater))
 
@@ -109,8 +110,8 @@  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
+         (inputs (map crate-name->package-name cargo-inputs))
+         (development-inputs (map crate-name->package-name
                                         cargo-development-inputs))
          (pkg `(package
                    (name ,guix-name)
@@ -123,9 +124,9 @@  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 (maybe-cargo-inputs inputs)
                                               (maybe-cargo-development-inputs
-                                                cargo-development-inputs)))
+                                                development-inputs)))
                    (home-page ,(match home-page
                                  (() "")
                                  (_ home-page)))
@@ -136,12 +137,22 @@  and LICENSE."
                                ((license) license)
                                (_ `(list ,@license)))))))
          (close-port port)
-         pkg))
-
-(define (crate->guix-package crate-name)
-  "Fetch the metadata for CRATE-NAME from crates.io, and return the
-`package' s-expression corresponding to that package, or #f on failure."
-  (crate-fetch crate-name make-crate-sexp))
+         ;; (pretty-print guix-name)
+         (values pkg (append cargo-development-inputs cargo-inputs))
+         ;; pkg
+         ))
+
+(define crate->guix-package
+  (memoize
+   (lambda* (crate-name)
+     "Fetch the metadata for CRATE-NAME from crates.io, and return the
+  `package' s-expression corresponding to that package, or #f on failure."
+     (crate-fetch crate-name make-crate-sexp))))
+
+(define* (crate-recursive-import package-name)
+  (recursive-import package-name #f
+                    #:repo->guix-package (lambda (name _) (crate->guix-package name))
+                    #:guix-name crate-name->package-name))
 
 (define (guix-package->crate-name package)
   "Return the crate name of PACKAGE."
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index cab9a4397b..b18cab8286 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -27,6 +27,7 @@ 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-41)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:export (guix-import-crate))
@@ -45,6 +46,8 @@  Import and convert the crate.io package for PACKAGE-NAME.\n"))
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
+  -r, --recursive        import packages recursively"))
+  (display (G_ "
   -V, --version          display version information and exit"))
   (newline)
   (show-bug-report-information))
@@ -58,6 +61,9 @@  Import and convert the crate.io package for PACKAGE-NAME.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix import crate")))
+         (option '(#\r "recursive") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'recursive #t result)))
          %standard-import-options))
 
 
@@ -83,11 +89,23 @@  Import and convert the crate.io package for PACKAGE-NAME.\n"))
                            (reverse opts))))
     (match args
       ((package-name)
-       (let ((sexp (crate->guix-package package-name)))
-         (unless sexp
-           (leave (G_ "failed to download meta-data for package '~a'~%")
-                  package-name))
-         sexp))
+       (if (assoc-ref opts 'recursive)
+           ;; Recursive import
+           (map (match-lambda
+                  ((and ('package ('name name) . rest) pkg)
+                   `(define-public ,(string->symbol name)
+                      ,pkg))
+                  (_ #f))
+                (reverse
+                 (stream->list
+                  (crate-recursive-import package-name))))
+           ;; Single import
+           (let ((sexp (crate->guix-package package-name ;; #f
+                                            )))
+             (unless sexp
+               (leave (G_ "failed to download meta-data for package '~a'~%")
+                      package-name))
+             sexp)))
       (()
        (leave (G_ "too few arguments~%")))
       ((many ...)
diff --git a/tests/crate.scm b/tests/crate.scm
index 72c3a13350..1787d4f2f6 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -25,9 +25,10 @@ 
   #:use-module (guix tests)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-41)
   #:use-module (srfi srfi-64))
 
-(define test-crate
+(define test-foo-crate
   "{
   \"crate\": {
     \"max_version\": \"1.0.0\",
@@ -39,7 +40,7 @@ 
   }
 }")
 
-(define test-dependencies
+(define test-foo-dependencies
   "{
   \"dependencies\": [
      {
@@ -49,6 +50,23 @@ 
   ]
 }")
 
+(define test-bar-crate
+  "{
+  \"crate\": {
+    \"max_version\": \"1.0.0\",
+    \"name\": \"bar\",
+    \"license\": \"MIT/Apache-2.0\",
+    \"description\": \"summary\",
+    \"homepage\": \"http://example.com\",
+    \"repository\": \"http://example.com\",
+  }
+}")
+
+(define test-bar-dependencies
+  "{
+  \"dependencies\": []
+}")
+
 (define test-source-hash
   "")
 
@@ -68,14 +86,14 @@ 
          (lambda (url . rest)
            (match url
              ("https://crates.io/api/v1/crates/foo"
-              (open-input-string test-crate))
+              (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"))))
               (open-input-string "empty file\n"))
              ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies"
-              (open-input-string test-dependencies))
+              (open-input-string test-foo-dependencies))
              (_ (error "Unexpected URL: " url)))))
     (match (crate->guix-package "foo")
       (('package
@@ -100,4 +118,70 @@ 
       (x
        (pk 'fail x #f)))))
 
+(test-assert "cargo-recursive-import"
+  ;; Replace network resources with sample data.
+  (mock ((guix http-client) http-fetch
+         (lambda (url . rest)
+           (match url
+             ("https://crates.io/api/v1/crates/foo"
+              (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"))))
+              (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/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
+                     (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))
+             (_ (error "Unexpected URL: " url)))))
+        (match (stream->list (crate-recursive-import "foo"))
+          ((('package
+              ('name "rust-foo")
+              ('version (? string? ver))
+              ('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)))
+            ('package
+              ('name "rust-bar")
+              ('version (? string? ver))
+              ('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)
+              ('home-page "http://example.com")
+              ('synopsis "summary")
+              ('description "summary")
+              ('license ('list 'license:expat 'license:asl2.0))))
+           #t)
+          (x
+           (pk 'fail x #f)))))
+
 (test-end "crate")
-- 
2.22.0