From 751bf2367edf54015792f339dcaca797cd7da937 Mon Sep 17 00:00:00 2001 From: Brian Leung 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(-) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index f6057dbf8b..5e81c015d8 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -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 (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 (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." diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 252875eeab..e58f5cba94 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -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)))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index cab9a4397b..9970b1a231 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,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 ...) diff --git a/tests/crate.scm b/tests/crate.scm index c14862ad9f..8e7b0bda9b 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -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