;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
#: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:)
+ #:use-module (guix memoization)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:export (crate->guix-package
guix-package->crate-name
+ string->license
+ crate-recursive-import
%crate-updater))
\f
crate-dependency?
json->crate-dependency
(id crate-dependency-id "crate_id") ;string
- (kind crate-dependency-kind "kind" ;'normal | 'dev
+ (kind crate-dependency-kind "kind" ;'normal | 'dev | 'build
string->symbol)
(requirement crate-dependency-requirement "req")) ;string
+(module-autoload! (current-module)
+ '(semver) '(string->semver semver<?))
+(module-autoload! (current-module)
+ '(semver ranges) '(string->semver-range semver-range-contains?))
+
(define (lookup-crate name)
"Look up NAME on https://crates.io and return the corresopnding <crate>
record or #f if it was not found."
(json->crate `(,@alist
("actual_versions" . ,versions))))))))
+(define lookup-crate* (memoize lookup-crate))
+
(define (crate-version-dependencies version)
"Return the list of <crate-dependency> records of VERSION, a
<crate-version>."
(url (string-append (%crate-base-url) path)))
(match (assoc-ref (or (json-fetch url) '()) "dependencies")
((? vector? vector)
- (map json->crate-dependency (vector->list vector)))
+ (delete-duplicates (map json->crate-dependency (vector->list vector))))
(_
'()))))
`((arguments (,'quasiquote ,args))))))
(define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
- home-page synopsis description license
- #:allow-other-keys)
+ home-page synopsis description license build?)
"Return the `package' s-expression for a rust package with the given NAME,
VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
and LICENSE."
+ (define (format-inputs inputs)
+ (map
+ (match-lambda
+ ((name version)
+ (list (crate-name->package-name name)
+ (version-major+minor version))))
+ inputs))
+
(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
- cargo-development-inputs))
+ (cargo-inputs (format-inputs cargo-inputs))
+ (cargo-development-inputs (format-inputs cargo-development-inputs))
(pkg `(package
(name ,guix-name)
(version ,version)
(base32
,(bytevector->nix-base32-string (port-sha256 port))))))
(build-system cargo-build-system)
- ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
+ ,@(maybe-arguments (append (if build?
+ '()
+ '(#:skip-build? #t))
+ (maybe-cargo-inputs cargo-inputs)
(maybe-cargo-development-inputs
cargo-development-inputs)))
(home-page ,(match home-page
- (() "")
+ ('null "")
(_ home-page)))
(synopsis ,synopsis)
(description ,(beautify-description description))
((license) license)
(_ `(list ,@license)))))))
(close-port port)
- pkg))
+ (package->definition pkg #t)))
-(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 (string->license string)
+ (filter-map (lambda (license)
+ (and (not (string-null? license))
+ (not (any (lambda (elem) (string=? elem license))
+ '("AND" "OR" "WITH")))
+ (or (spdx-string->license license)
+ 'unknown-license!)))
+ (string-split string (string->char-set " /"))))
-(define (crate->guix-package crate-name)
+(define* (crate->guix-package crate-name #:key version include-dev-deps? repo)
"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))))))
+`package' s-expression corresponding to that package, or #f on failure.
+When VERSION is specified, convert it into a semver range and attempt to fetch
+the latest version matching this semver range; otherwise fetch the latest
+version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also
+look up the development dependencs for the given crate."
+
+ (define (semver-range-contains-string? range version)
+ (semver-range-contains? (string->semver-range range)
+ (string->semver version)))
(define (normal-dependency? dependency)
- (eq? (crate-dependency-kind dependency) 'normal))
+ (or (eq? (crate-dependency-kind dependency) 'build)
+ (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)))))
+ (lookup-crate* crate-name))
+
+ (define version-number
+ (and crate
+ (or version
+ (crate-latest-version crate))))
+
+ ;; find the highest version of a crate that fulfills the semver <range>
+ (define (find-crate-version crate range)
+ (let* ((semver-range (string->semver-range range))
+ (versions
+ (sort
+ (filter (lambda (entry)
+ (semver-range-contains? semver-range (first entry)))
+ (map (lambda (ver)
+ (list (string->semver (crate-version-number ver))
+ ver))
+ (crate-versions crate)))
+ (match-lambda* (((semver _) ...)
+ (apply semver<? semver))))))
+ (and (not (null-list? versions))
+ (second (last versions)))))
+
+ (define version*
+ (and crate
+ (find-crate-version crate version-number)))
+
+ ;; sort and map the dependencies to a list containing
+ ;; pairs of (name version)
+ (define (sort-map-dependencies deps)
+ (sort (map (lambda (dep)
+ (let* ((name (crate-dependency-id dep))
+ (crate (lookup-crate* name))
+ (req (crate-dependency-requirement dep))
+ (ver (find-crate-version crate req)))
+ (list name
+ (crate-version-number ver))))
+ deps)
+ (match-lambda* (((name _) ...)
+ (apply string-ci<? name)))))
+
+ (and crate version*
+ (let* ((dependencies (crate-version-dependencies version*))
+ (dep-crates dev-dep-crates (partition normal-dependency? dependencies))
+ (cargo-inputs (sort-map-dependencies dep-crates))
+ (cargo-development-inputs (if include-dev-deps?
+ (sort-map-dependencies dev-dep-crates)
+ '())))
+ (values
+ (make-crate-sexp #:build? include-dev-deps?
+ #: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))
+ (append cargo-inputs cargo-development-inputs)))))
+
+(define* (crate-recursive-import crate-name #:key version)
+ (recursive-import crate-name
+ #:repo->guix-package (lambda* params
+ ;; download development dependencies only for the top level package
+ (let ((include-dev-deps? (equal? (car params) crate-name))
+ (crate->guix-package* (memoize crate->guix-package)))
+ (apply crate->guix-package*
+ (append params `(#:include-dev-deps? ,include-dev-deps?)))))
+ #:version version
+ #:guix-name crate-name->package-name))
(define (guix-package->crate-name package)
"Return the crate name of PACKAGE."
((name _ ...) name))))
(define (crate-name->package-name name)
- (string-append "rust-" (string-join (string-split name #\_) "-")))
+ (guix-name "rust-" name))
\f
;;;
;;; Updater
;;;
-(define (crate-package? package)
- "Return true if PACKAGE is a Rust crate from crates.io."
- (let ((source-url (and=> (package-source package) origin-uri))
- (fetch-method (and=> (package-source package) origin-method)))
- (and (eq? fetch-method download:url-fetch)
- (match source-url
- ((? string?)
- (crate-url? source-url))
- ((source-url ...)
- (any crate-url? source-url))))))
+(define crate-package?
+ (url-predicate crate-url?))
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
HCoop / jackhill / guix / guix.git / blobdiff