diff options
| -rw-r--r-- | guix/build-system/cargo.scm | 11 | ||||
| -rw-r--r-- | guix/import/crate.scm | 153 | ||||
| -rw-r--r-- | tests/crate.scm | 13 |
3 files changed, 131 insertions, 46 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 10a1bac844..1e8b3a578e 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -35,12 +35,17 @@ #:export (%cargo-build-system-modules %cargo-utils-modules cargo-build-system + %crate-base-url crate-url crate-url? crate-uri)) -(define crate-url "https://crates.io/api/v1/crates/") -(define crate-url? (cut string-prefix? crate-url <>)) +(define %crate-base-url + (make-parameter "https://crates.io")) +(define crate-url + (string-append (%crate-base-url) "/api/v1/crates/")) +(define crate-url? + (cut string-prefix? crate-url <>)) (define (crate-uri name version) "Return a URI string for the crate package hosted at crates.io corresponding diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 52c5cb1c30..b674323177 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module ((guix download) #:prefix download:) #:use-module (gcrypt hash) #:use-module (guix http-client) + #:use-module (guix json) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) @@ -30,7 +32,6 @@ #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) ; recursive #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -39,46 +40,82 @@ guix-package->crate-name %crate-updater)) -(define (crate-fetch crate-name callback) - "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + +;;; +;;; Interface to https://crates.io/api/v1. +;;; - (define (crates->inputs crates) - (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?)) +;; Crates. A crate is essentially a "package". It can have several +;; "versions", each of which has its own set of dependencies, license, +;; etc.--see <crate-version> below. +(define-json-mapping <crate> make-crate crate? + json->crate + (name crate-name) ;string + (latest-version crate-latest-version "max_version") ;string + (home-page crate-home-page "homepage") ;string | #nil + (repository crate-repository) ;string + (description crate-description) ;string + (keywords crate-keywords ;list of strings + "keywords" vector->list) + (categories crate-categories ;list of strings + "categories" vector->list) + (versions crate-versions "actual_versions" ;list of <crate-version> + (lambda (vector) + (map json->crate-version + (vector->list vector)))) + (links crate-links)) ;alist - (define (string->license string) - (map spdx-string->license (string-split string #\/))) +;; Crate version. +(define-json-mapping <crate-version> make-crate-version crate-version? + json->crate-version + (id crate-version-id) ;integer + (number crate-version-number "num") ;string + (download-path crate-version-download-path "dl_path") ;string + (readme-path crate-version-readme-path "readme_path") ;string + (license crate-version-license "license") ;string + (links crate-version-links)) ;alist + +;; Crate dependency. Each dependency (each edge in the graph) is annotated as +;; being a "normal" dependency or a development dependency. There also +;; information about the minimum required version, such as "^0.0.41". +(define-json-mapping <crate-dependency> make-crate-dependency + crate-dependency? + json->crate-dependency + (id crate-dependency-id "crate_id") ;string + (kind crate-dependency-kind "kind" ;'normal | 'dev + string->symbol) + (requirement crate-dependency-requirement "req")) ;string + +(define (lookup-crate name) + "Look up NAME on https://crates.io and return the corresopnding <crate> +record or #f if it was not found." + (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/" + name)))) + (and=> (and json (assoc-ref json "crate")) + (lambda (alist) + ;; The "versions" field of ALIST is simply a list of version IDs + ;; (integers). Here, we squeeze in the actual version + ;; dictionaries that are not part of ALIST but are just more + ;; convenient handled this way. + (let ((versions (or (assoc-ref json "versions") '#()))) + (json->crate `(,@alist + ("actual_versions" . ,versions)))))))) + +(define (crate-version-dependencies version) + "Return the list of <crate-dependency> records of VERSION, a +<crate-version>." + (let* ((path (assoc-ref (crate-version-links version) "dependencies")) + (url (string-append (%crate-base-url) path))) + (match (assoc-ref (or (json-fetch url) '()) "dependencies") + ((? vector? vector) + (map json->crate-dependency (vector->list vector))) + (_ + '())))) - (define (crate-kind-predicate kind) - (lambda (dep) (string=? (assoc-ref dep "kind") kind))) - - (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) - (crate (assoc-ref crate-json "crate")) - (name (assoc-ref crate "name")) - (version (assoc-ref crate "max_version")) - (homepage (assoc-ref crate "homepage")) - (repository (assoc-ref crate "repository")) - (synopsis (assoc-ref crate "description")) - (description (assoc-ref crate "description")) - (license (or (and=> (assoc-ref crate "license") - string->license) - '())) ;missing license info - (path (string-append "/" version "/dependencies")) - (deps-json (json-fetch (string-append crate-url name path))) - (deps (vector->list (assoc-ref deps-json "dependencies"))) - (dep-crates (filter (crate-kind-predicate "normal") deps)) - (dev-dep-crates - (filter (lambda (dep) - (not ((crate-kind-predicate "normal") dep))) deps)) - (cargo-inputs (crates->inputs dep-crates)) - (cargo-development-inputs (crates->inputs dev-dep-crates)) - (home-page (match homepage - (() repository) - (_ homepage)))) - (callback #:name name #:version version - #:cargo-inputs cargo-inputs - #:cargo-development-inputs cargo-development-inputs - #:home-page home-page #:synopsis synopsis - #:description description #:license license))) + +;;; +;;; Converting crates to Guix packages. +;;; (define (maybe-cargo-inputs package-names) (match (package-names->package-inputs package-names) @@ -141,7 +178,38 @@ and LICENSE." (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)) + (define (string->license string) + (map spdx-string->license (string-split string #\/))) + + (define (normal-dependency? dependency) + (eq? (crate-dependency-kind dependency) 'normal)) + + (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))))) (define (guix-package->crate-name package) "Return the crate name of PACKAGE." @@ -157,6 +225,7 @@ and LICENSE." (define (crate-name->package-name name) (string-append "rust-" (string-join (string-split name #\_) "-"))) + ;;; ;;; Updater ;;; @@ -175,9 +244,9 @@ and LICENSE." (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." (let* ((crate-name (guix-package->crate-name package)) - (callback (lambda* (#:key version #:allow-other-keys) version)) - (version (crate-fetch crate-name callback)) - (url (crate-uri crate-name version))) + (crate (lookup-crate crate-name)) + (version (crate-latest-version crate)) + (url (crate-uri crate-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/tests/crate.scm b/tests/crate.scm index 72c3a13350..8a232ba06c 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,10 +33,20 @@ \"crate\": { \"max_version\": \"1.0.0\", \"name\": \"foo\", - \"license\": \"MIT/Apache-2.0\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", + \"keywords\": [\"dummy\" \"test\"], + \"categories\": [\"test\"] + \"actual_versions\": [ + { \"id\": \"foo\", + \"num\": \"1.0.0\", + \"license\": \"MIT/Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" + } + } + ] } }") |