guix/import/crate.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 David Craven <david@craven.ch>
   3 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix import crate)
  22   #:use-module (guix base32)
  23   #:use-module (guix build-system cargo)
  24   #:use-module ((guix download) #:prefix download:)
  25   #:use-module (gcrypt hash)
  26   #:use-module (guix http-client)
  27   #:use-module (guix import json)
  28   #:use-module (guix import utils)
  29   #:use-module ((guix licenses) #:prefix license:)
  30   #:use-module (guix memoization)
  31   #:use-module (guix monads)
  32   #:use-module (guix packages)
  33   #:use-module (guix upstream)
  34   #:use-module (guix utils)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 regex)
  37   #:use-module (json)
  38   #:use-module (srfi srfi-1)
  39   #:use-module (srfi srfi-2)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-71)
  42   #:export (crate->guix-package
  43             guix-package->crate-name
  44             string->license
  45             crate-recursive-import
  46             %crate-updater))
  47
  48 \f
  49 ;;;
  50 ;;; Interface to https://crates.io/api/v1.
  51 ;;;
  52
  53 ;; Crates.  A crate is essentially a "package".  It can have several
  54 ;; "versions", each of which has its own set of dependencies, license,
  55 ;; etc.--see <crate-version> below.
  56 (define-json-mapping <crate> make-crate crate?
  57   json->crate
  58   (name          crate-name)                      ;string
  59   (latest-version crate-latest-version "max_version") ;string
  60   (home-page     crate-home-page "homepage")      ;string | #nil
  61   (repository    crate-repository)                ;string
  62   (description   crate-description)               ;string
  63   (keywords      crate-keywords                   ;list of strings
  64                  "keywords" vector->list)
  65   (categories    crate-categories                 ;list of strings
  66                  "categories" vector->list)
  67   (versions      crate-versions "actual_versions" ;list of <crate-version>
  68                  (lambda (vector)
  69                    (map json->crate-version
  70                         (vector->list vector))))
  71   (links         crate-links))                    ;alist
  72
  73 ;; Crate version.
  74 (define-json-mapping <crate-version> make-crate-version crate-version?
  75   json->crate-version
  76   (id            crate-version-id)                ;integer
  77   (number        crate-version-number "num")      ;string
  78   (download-path crate-version-download-path "dl_path") ;string
  79   (readme-path   crate-version-readme-path "readme_path") ;string
  80   (license       crate-version-license "license") ;string
  81   (links         crate-version-links))            ;alist
  82
  83 ;; Crate dependency.  Each dependency (each edge in the graph) is annotated as
  84 ;; being a "normal" dependency or a development dependency.  There also
  85 ;; information about the minimum required version, such as "^0.0.41".
  86 (define-json-mapping <crate-dependency> make-crate-dependency
  87   crate-dependency?
  88   json->crate-dependency
  89   (id            crate-dependency-id "crate_id")  ;string
  90   (kind          crate-dependency-kind "kind"     ;'normal | 'dev | 'build
  91                  string->symbol)
  92   (requirement   crate-dependency-requirement "req")) ;string
  93
  94 (module-autoload! (current-module)
  95                   '(semver) '(string->semver semver<?))
  96 (module-autoload! (current-module)
  97                   '(semver ranges) '(string->semver-range semver-range-contains?))
  98
  99 (define (lookup-crate name)
 100   "Look up NAME on https://crates.io and return the corresopnding <crate>
 101 record or #f if it was not found."
 102   (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
 103                                          name))))
 104     (and=> (and json (assoc-ref json "crate"))
 105            (lambda (alist)
 106              ;; The "versions" field of ALIST is simply a list of version IDs
 107              ;; (integers).  Here, we squeeze in the actual version
 108              ;; dictionaries that are not part of ALIST but are just more
 109              ;; convenient handled this way.
 110              (let ((versions (or (assoc-ref json "versions") '#())))
 111                (json->crate `(,@alist
 112                               ("actual_versions" . ,versions))))))))
 113
 114 (define lookup-crate* (memoize lookup-crate))
 115
 116 (define (crate-version-dependencies version)
 117   "Return the list of <crate-dependency> records of VERSION, a
 118 <crate-version>."
 119   (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
 120          (url  (string-append (%crate-base-url) path)))
 121     (match (assoc-ref (or (json-fetch url) '()) "dependencies")
 122       ((? vector? vector)
 123        (delete-duplicates (map json->crate-dependency (vector->list vector))))
 124       (_
 125        '()))))
 126
 127 \f
 128 ;;;
 129 ;;; Converting crates to Guix packages.
 130 ;;;
 131
 132 (define (maybe-cargo-inputs package-names)
 133   (match (package-names->package-inputs package-names)
 134     (()
 135      '())
 136     ((package-inputs ...)
 137      `(#:cargo-inputs ,package-inputs))))
 138
 139 (define (maybe-cargo-development-inputs package-names)
 140   (match (package-names->package-inputs package-names)
 141     (()
 142      '())
 143     ((package-inputs ...)
 144      `(#:cargo-development-inputs ,package-inputs))))
 145
 146 (define (maybe-arguments arguments)
 147   (match arguments
 148     (()
 149      '())
 150     ((args ...)
 151      `((arguments (,'quasiquote ,args))))))
 152
 153 (define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
 154                           home-page synopsis description license build?)
 155   "Return the `package' s-expression for a rust package with the given NAME,
 156 VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
 157 and LICENSE."
 158   (define (format-inputs inputs)
 159     (map
 160      (match-lambda
 161       ((name version)
 162        (list (crate-name->package-name name)
 163              (version-major+minor version))))
 164      inputs))
 165
 166   (let* ((port (http-fetch (crate-uri name version)))
 167          (guix-name (crate-name->package-name name))
 168          (cargo-inputs (format-inputs cargo-inputs))
 169          (cargo-development-inputs (format-inputs cargo-development-inputs))
 170          (pkg `(package
 171                    (name ,guix-name)
 172                    (version ,version)
 173                    (source (origin
 174                              (method url-fetch)
 175                              (uri (crate-uri ,name version))
 176                              (file-name (string-append name "-" version ".tar.gz"))
 177                              (sha256
 178                               (base32
 179                                ,(bytevector->nix-base32-string (port-sha256 port))))))
 180                    (build-system cargo-build-system)
 181                    ,@(maybe-arguments (append (if build?
 182                                                  '()
 183                                                  '(#:skip-build? #t))
 184                                               (maybe-cargo-inputs cargo-inputs)
 185                                               (maybe-cargo-development-inputs
 186                                                 cargo-development-inputs)))
 187                    (home-page ,(match home-page
 188                                  ('null "")
 189                                  (_ home-page)))
 190                    (synopsis ,synopsis)
 191                    (description ,(beautify-description description))
 192                    (license ,(match license
 193                                (() #f)
 194                                ((license) license)
 195                                (_ `(list ,@license)))))))
 196          (close-port port)
 197          (package->definition pkg #t)))
 198
 199 (define (string->license string)
 200   (filter-map (lambda (license)
 201                 (and (not (string-null? license))
 202                      (not (any (lambda (elem) (string=? elem license))
 203                                '("AND" "OR" "WITH")))
 204                      (or (spdx-string->license license)
 205                          'unknown-license!)))
 206               (string-split string (string->char-set " /"))))
 207
 208 (define* (crate->guix-package crate-name #:key version include-dev-deps? repo)
 209   "Fetch the metadata for CRATE-NAME from crates.io, and return the
 210 `package' s-expression corresponding to that package, or #f on failure.
 211 When VERSION is specified, convert it into a semver range and attempt to fetch
 212 the latest version matching this semver range; otherwise fetch the latest
 213 version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also
 214 look up the development dependencs for the given crate."
 215
 216   (define (semver-range-contains-string? range version)
 217     (semver-range-contains? (string->semver-range range)
 218                             (string->semver version)))
 219
 220   (define (normal-dependency? dependency)
 221     (or (eq? (crate-dependency-kind dependency) 'build)
 222         (eq? (crate-dependency-kind dependency) 'normal)))
 223
 224   (define crate
 225     (lookup-crate* crate-name))
 226
 227   (define version-number
 228     (and crate
 229          (or version
 230              (crate-latest-version crate))))
 231
 232   ;; find the highest version of a crate that fulfills the semver <range>
 233   (define (find-crate-version crate range)
 234     (let* ((semver-range (string->semver-range range))
 235            (versions
 236             (sort
 237              (filter (lambda (entry)
 238                        (semver-range-contains? semver-range (first entry)))
 239                      (map (lambda (ver)
 240                             (list (string->semver (crate-version-number ver))
 241                                   ver))
 242                           (crate-versions crate)))
 243              (match-lambda* (((semver _) ...)
 244                              (apply semver<? semver))))))
 245       (and (not (null-list? versions))
 246            (second (last versions)))))
 247
 248   (define version*
 249     (and crate
 250          (find-crate-version crate version-number)))
 251
 252   ;; sort and map the dependencies to a list containing
 253   ;; pairs of (name version)
 254   (define (sort-map-dependencies deps)
 255     (sort (map (lambda (dep)
 256                  (let* ((name (crate-dependency-id dep))
 257                         (crate (lookup-crate* name))
 258                         (req (crate-dependency-requirement dep))
 259                         (ver (find-crate-version crate req)))
 260                    (list name
 261                          (crate-version-number ver))))
 262                deps)
 263           (match-lambda* (((name _) ...)
 264                           (apply string-ci<? name)))))
 265
 266   (and crate version*
 267        (let* ((dependencies (crate-version-dependencies version*))
 268               (dep-crates dev-dep-crates (partition normal-dependency? dependencies))
 269               (cargo-inputs (sort-map-dependencies dep-crates))
 270               (cargo-development-inputs (if include-dev-deps?
 271                                             (sort-map-dependencies dev-dep-crates)
 272                                             '())))
 273          (values
 274           (make-crate-sexp #:build? include-dev-deps?
 275                            #:name crate-name
 276                            #:version (crate-version-number version*)
 277                            #:cargo-inputs cargo-inputs
 278                            #:cargo-development-inputs cargo-development-inputs
 279                            #:home-page (or (crate-home-page crate)
 280                                            (crate-repository crate))
 281                            #:synopsis (crate-description crate)
 282                            #:description (crate-description crate)
 283                            #:license (and=> (crate-version-license version*)
 284                                             string->license))
 285           (append cargo-inputs cargo-development-inputs)))))
 286
 287 (define* (crate-recursive-import crate-name #:key version)
 288   (recursive-import crate-name
 289                     #:repo->guix-package (lambda* params
 290                       ;; download development dependencies only for the top level package
 291                       (let ((include-dev-deps? (equal? (car params) crate-name))
 292                             (crate->guix-package* (memoize crate->guix-package)))
 293                         (apply crate->guix-package*
 294                                (append params `(#:include-dev-deps? ,include-dev-deps?)))))
 295                     #:version version
 296                     #:guix-name crate-name->package-name))
 297
 298 (define (guix-package->crate-name package)
 299   "Return the crate name of PACKAGE."
 300   (and-let* ((origin (package-source package))
 301              (uri (origin-uri origin))
 302              (crate-url? uri)
 303              (len (string-length crate-url))
 304              (path (xsubstring uri len))
 305              (parts (string-split path #\/)))
 306     (match parts
 307       ((name _ ...) name))))
 308
 309 (define (crate-name->package-name name)
 310   (guix-name "rust-" name))
 311
 312 \f
 313 ;;;
 314 ;;; Updater
 315 ;;;
 316
 317 (define crate-package?
 318   (url-predicate crate-url?))
 319
 320 (define (latest-release package)
 321   "Return an <upstream-source> for the latest release of PACKAGE."
 322   (let* ((crate-name (guix-package->crate-name package))
 323          (crate      (lookup-crate crate-name))
 324          (version    (crate-latest-version crate))
 325          (url        (crate-uri crate-name version)))
 326     (upstream-source
 327      (package (package-name package))
 328      (version version)
 329      (urls (list url)))))
 330
 331 (define %crate-updater
 332   (upstream-updater
 333    (name 'crates)
 334    (description "Updater for crates.io packages")
 335    (pred crate-package?)
 336    (latest latest-release)))
 337