From 751bf2367edf54015792f339dcaca797cd7da937 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 | 131 +++++++++++++------------
guix/import/utils.scm | 16 ++--
guix/scripts/import/crate.scm | 32 ++++++-
tests/crate.scm | 173 +++++++++++++++++++++++++++++++++-
4 files changed, 273 insertions(+), 79 deletions(-)
@@ -38,6 +38,7 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
#:export (crate->guix-package
+ crate-recursive-import
guix-package->crate-name
%crate-updater))
@@ -147,78 +148,86 @@ 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)
- (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 ".tar.gz"))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string (port-sha256 port))))))
+ (build-system cargo-build-system)
+ ,@(maybe-arguments (append (maybe-cargo-inputs inputs)
+ (maybe-cargo-development-inputs
+ 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)
+ (values pkg
+ (lset-union equal? cargo-inputs cargo-development-inputs))))
(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->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."
- (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 (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 (normal-dependency? dependency)
- (eq? (crate-dependency-kind dependency) 'normal))
+(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."
+ (define crate
+ (lookup-crate crate-name))
- (define crate
- (lookup-crate crate-name))
+ (and crate
+ (let* ((version (find (lambda (version)
+ (string=? (crate-version-number version)
+ (crate-latest-version crate)))
+ (crate-versions crate)))
+ (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<?)))
+ (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)))))))
- (and crate
- (let* ((version (find (lambda (version)
- (string=? (crate-version-number version)
- (crate-latest-version crate)))
- (crate-versions crate)))
- (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<?)))
- (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)))))
+(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."
@@ -381,16 +381,16 @@ dependencies."
((prev (next . rest) done)
(define (handle? dep)
(and
- (not (equal? dep next))
- (not (member dep done))
- (not (exists? dep))))
+ (not (equal? dep next))
+ (not (member dep done))
+ (not (exists? dep))))
(receive (package . dependencies) (repo->guix-package next repo)
(list
- (if package package '()) ;; default #f on failure would interrupt
- (if package
- (lset-union equal? rest (filter handle? (car dependencies)))
- rest)
- (cons next done))))
+ (or package next)
+ (if package
+ (lset-union equal? rest (filter handle? (car dependencies)))
+ rest)
+ (cons next done))))
((prev '() done)
(list #f '() done))))
@@ -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,27 @@ 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))
+ ((and string? pkg-name)
+ ;; (format #f (G_ "failed to download meta-data for package '~a'") dep-name)
+ (string-append "failed to download meta-data for package '"
+ pkg-name
+ "'"))
+ (_ #f))
+ (reverse
+ (stream->list
+ (crate-recursive-import package-name))))
+ ;; Single import
+ (let ((sexp (crate->guix-package package-name)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ package-name))
+ sexp)))
(()
(leave (G_ "too few arguments~%")))
((many ...)
@@ -26,9 +26,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\",
@@ -50,16 +51,81 @@
}
}")
-(define test-dependencies
+(define test-foo-dependencies
"{
\"dependencies\": [
{
\"crate_id\": \"bar\",
\"kind\": \"normal\",
+ },
+ {
+ \"crate_id\": \"baz\",
+ \"kind\": \"normal\",
+ }
+ ]
+}")
+
+(define test-bar-crate
+ "{
+ \"crate\": {
+ \"max_version\": \"1.0.0\",
+ \"name\": \"bar\",
+ \"description\": \"summary\",
+ \"homepage\": \"http://example.com\",
+ \"repository\": \"http://example.com\",
+ \"keywords\": [\"dummy\" \"test\"],
+ \"categories\": [\"test\"]
+ \"actual_versions\": [
+ { \"id\": \"bar\",
+ \"num\": \"1.0.0\",
+ \"license\": \"MIT OR Apache-2.0\",
+ \"links\": {
+ \"dependencies\": \"/api/v1/crates/bar/1.0.0/dependencies\"
+ }
+ }
+ ]
+ \"license\": \"MIT OR Apache-2.0\",
+ }
+}")
+
+(define test-bar-dependencies
+ "{
+ \"dependencies\": [
+ {
+ \"crate_id\": \"baz\",
+ \"kind\": \"normal\",
}
]
}")
+(define test-baz-crate
+ "{
+ \"crate\": {
+ \"max_version\": \"1.0.0\",
+ \"name\": \"baz\",
+ \"description\": \"summary\",
+ \"homepage\": \"http://example.com\",
+ \"repository\": \"http://example.com\",
+ \"keywords\": [\"dummy\" \"test\"],
+ \"categories\": [\"test\"]
+ \"actual_versions\": [
+ { \"id\": \"baz\",
+ \"num\": \"1.0.0\",
+ \"license\": \"MIT OR Apache-2.0\",
+ \"links\": {
+ \"dependencies\": \"/api/v1/crates/baz/1.0.0/dependencies\"
+ }
+ }
+ ]
+ \"license\": \"MIT OR Apache-2.0\",
+ }
+}")
+
+(define test-baz-dependencies
+ "{
+\"dependencies\": []
+}")
+
(define test-source-hash
"")
@@ -79,14 +145,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
@@ -102,7 +168,8 @@
('build-system 'cargo-build-system)
('arguments
('quasiquote
- ('#:cargo-inputs (("rust-bar" ('unquote rust-bar))))))
+ ('#:cargo-inputs (("rust-bar" ('unquote rust-bar))
+ ("rust-baz" ('unquote rust-baz))))))
('home-page "http://example.com")
('synopsis "summary")
('description "summary")
@@ -111,4 +178,100 @@
(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))
+ ("https://crates.io/api/v1/crates/baz"
+ (open-input-string test-baz-crate))
+ ("https://crates.io/api/v1/crates/baz/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/baz/1.0.0/dependencies"
+ (open-input-string test-baz-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))
+ ("rust-baz" ('unquote rust-baz))))))
+ ('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)
+ ('arguments
+ ('quasiquote
+ ('#:cargo-inputs (("rust-baz" ('unquote rust-baz))))))
+ ('home-page "http://example.com")
+ ('synopsis "summary")
+ ('description "summary")
+ ('license ('list 'license:expat 'license:asl2.0)))
+ ('package
+ ('name "rust-baz")
+ ('version (? string? ver))
+ ('source
+ ('origin
+ ('method 'url-fetch)
+ ('uri ('crate-uri "baz" '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.23.0