* [bug#37254] [PATCH 2/4] ci: Use (guix json) and adjust for Guile-JSON 3.x.
2019-09-01 14:56 ` [bug#37254] [PATCH 1/4] Add (guix json) Ludovic Courtès
@ 2019-09-01 14:56 ` Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 3/4] import: create: Separate crates.io API from actual conversion Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 4/4] import: crate: Correct interpretation of dual-licensing strings Ludovic Courtès
2 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2019-09-01 14:56 UTC (permalink / raw)
To: 37254
This is in part a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d.
* guix/ci.scm (<build>, <checkout>, <evaluation>): Define using
'define-json-mapping'.
(json->build, json->checkout, json->evaluation): Remove.
(queued-builds, latest-builds, latest-evaluations): Pass JSON arrays
through 'vector->list' to adjust for Guile-JSON 3.x.
(evaluations-for-commit): Fix typo to really export.
---
guix/ci.scm | 68 +++++++++++++++++++++--------------------------------
1 file changed, 27 insertions(+), 41 deletions(-)
diff --git a/guix/ci.scm b/guix/ci.scm
index 1727297dd7..9e21996023 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,9 +18,10 @@
(define-module (guix ci)
#:use-module (guix http-client)
- #:autoload (json parser) (json->scm)
+ #:use-module (guix json)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
#:export (build?
build-id
build-derivation
@@ -42,7 +43,7 @@
queued-builds
latest-builds
latest-evaluations
- evaluation-for-commit))
+ evaluations-for-commit))
;;; Commentary:
;;;
@@ -51,28 +52,31 @@
;;;
;;; Code:
-(define-record-type <build>
- (make-build id derivation system status timestamp)
- build?
- (id build-id) ;integer
+(define-json-mapping <build> make-build build?
+ json->build
+ (id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(system build-system) ;string
- (status build-status) ;integer
+ (status build-status "buildstatus" ) ;integer
(timestamp build-timestamp)) ;integer
-(define-record-type <checkout>
- (make-checkout commit input)
- checkout?
+(define-json-mapping <checkout> make-checkout checkout?
+ json->checkout
(commit checkout-commit) ;string (SHA1)
(input checkout-input)) ;string (name)
-(define-record-type <evaluation>
- (make-evaluation id spec complete? checkouts)
- evaluation?
+(define-json-mapping <evaluation> make-evaluation evaluation?
+ json->evaluation
(id evaluation-id) ;integer
(spec evaluation-spec) ;string
- (complete? evaluation-complete?) ;Boolean
- (checkouts evaluation-checkouts)) ;<checkout>*
+ (complete? evaluation-complete? "in-progress"
+ (match-lambda
+ (0 #t)
+ (_ #f))) ;Boolean
+ (checkouts evaluation-checkouts "checkouts" ;<checkout>*
+ (lambda (checkouts)
+ (map json->checkout
+ (vector->list checkouts)))))
(define %query-limit
;; Max number of builds requested in queries.
@@ -84,18 +88,11 @@
(close-port port)
json))
-(define (json->build json)
- (make-build (hash-ref json "id")
- (hash-ref json "derivation")
- (hash-ref json "system")
- (hash-ref json "buildstatus")
- (hash-ref json "timestamp")))
-
(define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL."
(let ((queue (json-fetch (string-append url "/api/queue?nr="
(number->string limit)))))
- (map json->build queue)))
+ (map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system)
@@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
- (map json->build latest)))
-
-(define (json->checkout json)
- (make-checkout (hash-ref json "commit")
- (hash-ref json "input")))
-
-(define (json->evaluation json)
- (make-evaluation (hash-ref json "id")
- (hash-ref json "specification")
- (case (hash-ref json "in-progress")
- ((0) #t)
- (else #f))
- (map json->checkout (hash-ref json "checkouts"))))
+ (map json->build (vector->list latest))))
(define* (latest-evaluations url #:optional (limit %query-limit))
"Return the latest evaluations performed by the CI server at URL."
(map json->evaluation
- (json->scm
- (http-fetch (string-append url "/api/evaluations?nr="
- (number->string limit))))))
+ (vector->list
+ (json->scm
+ (http-fetch (string-append url "/api/evaluations?nr="
+ (number->string limit)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
--
2.23.0
^ permalink raw reply related [flat|nested] 7+ messages in thread* [bug#37254] [PATCH 3/4] import: create: Separate crates.io API from actual conversion.
2019-09-01 14:56 ` [bug#37254] [PATCH 1/4] Add (guix json) Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 2/4] ci: Use (guix json) and adjust for Guile-JSON 3.x Ludovic Courtès
@ 2019-09-01 14:56 ` Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 4/4] import: crate: Correct interpretation of dual-licensing strings Ludovic Courtès
2 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2019-09-01 14:56 UTC (permalink / raw)
To: 37254
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.
---
guix/build-system/cargo.scm | 11 ++-
guix/import/crate.scm | 150 ++++++++++++++++++++++++++----------
tests/crate.scm | 13 +++-
3 files changed, 128 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..bcd5068e6c 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."
+\f
+;;;
+;;; 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
- (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)))
+;; 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)))
+ (_
+ '()))))
+
+\f
+;;;
+;;; Converting crates to Guix packages.
+;;;
(define (maybe-cargo-inputs package-names)
(match (package-names->package-inputs package-names)
@@ -141,7 +178,35 @@ 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))
+
+ (let* ((crate (lookup-crate crate-name))
+ (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 +222,7 @@ and LICENSE."
(define (crate-name->package-name name)
(string-append "rust-" (string-join (string-split name #\_) "-")))
+\f
;;;
;;; Updater
;;;
@@ -175,9 +241,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\"
+ }
+ }
+ ]
}
}")
--
2.23.0
^ permalink raw reply related [flat|nested] 7+ messages in thread* [bug#37254] [PATCH 4/4] import: crate: Correct interpretation of dual-licensing strings.
2019-09-01 14:56 ` [bug#37254] [PATCH 1/4] Add (guix json) Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 2/4] ci: Use (guix json) and adjust for Guile-JSON 3.x Ludovic Courtès
2019-09-01 14:56 ` [bug#37254] [PATCH 3/4] import: create: Separate crates.io API from actual conversion Ludovic Courtès
@ 2019-09-01 14:56 ` Ludovic Courtès
2 siblings, 0 replies; 7+ messages in thread
From: Ludovic Courtès @ 2019-09-01 14:56 UTC (permalink / raw)
To: 37254
* guix/import/crate.scm (%dual-license-rx): New variable.
(crate->guix-package)[string->license]: Rewrite to match it.
* tests/crate.scm (test-crate): Adjust "license" field to current
practice.
---
guix/import/crate.scm | 11 ++++++++++-
tests/crate.scm | 2 +-
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index bcd5068e6c..a1cbf33361 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -32,6 +32,7 @@
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
@@ -175,11 +176,19 @@ and LICENSE."
(close-port port)
pkg))
+(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)
- (map spdx-string->license (string-split string #\/)))
+ (match (regexp-exec %dual-license-rx string)
+ (#f (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))
diff --git a/tests/crate.scm b/tests/crate.scm
index 8a232ba06c..c14862ad9f 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -41,7 +41,7 @@
\"actual_versions\": [
{ \"id\": \"foo\",
\"num\": \"1.0.0\",
- \"license\": \"MIT/Apache-2.0\",
+ \"license\": \"MIT OR Apache-2.0\",
\"links\": {
\"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\"
}
--
2.23.0
^ permalink raw reply related [flat|nested] 7+ messages in thread