05/07: import: crate: Separate crates.io API from actual conversion.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 2791870d09afd247a011bc8cb6cf88661729bd98
Author: Ludovic Courtès <address@hidden>
Date:   Sun Sep 1 16:20:36 2019 +0200

    import: crate: Separate crates.io API from actual conversion.
    
    This provides a clean separation between bindings to the
    https://crates.io/api/v1 API and actual conversion to Guix package
    sexps.
    
    As a side-effect, it fixes things like "guix import blake2-rfc", "guix
    refresh -t crates", etc.
    
    * guix/import/crate.scm (<crate>, <crate-version>, <crate-dependency>):
    New record types.
    (lookup-crate, crate-version-dependencies): New procedures.
    (crate-fetch): Remove.
    (crate->guix-package): Rewrite to use the new API.
    (latest-release): Likewise.
    * guix/build-system/cargo.scm (%crate-base-url): New variable.
    * tests/crate.scm (test-crate): Update accordingly.
    
    fixlet
---
 guix/build-system/cargo.scm |  11 +++-
 guix/import/crate.scm       | 153 ++++++++++++++++++++++++++++++++------------
 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 10a1bac..1e8b3a5 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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Andreas Enge <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2016 David Craven <address@hidden>
@@ -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 52c5cb1..b674323 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 <address@hidden>
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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 72c3a13..8a232ba 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <address@hidden>
 ;;; Copyright © 2016 David Craven <address@hidden>
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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\"
+        }
+      }
+    ]
   }
 }")