guix/import/crate.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 David Craven <david@craven.ch>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix import crate)
  21   #:use-module (guix base32)
  22   #:use-module (guix build-system cargo)
  23   #:use-module ((guix download) #:prefix download:)
  24   #:use-module (gcrypt hash)
  25   #:use-module (guix http-client)
  26   #:use-module (guix json)
  27   #:use-module (guix import json)
  28   #:use-module (guix import utils)
  29   #:use-module ((guix licenses) #:prefix license:)
  30   #:use-module (guix monads)
  31   #:use-module (guix packages)
  32   #:use-module (guix upstream)
  33   #:use-module (guix utils)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 regex)
  36   #:use-module (json)
  37   #:use-module (srfi srfi-1)
  38   #:use-module (srfi srfi-2)
  39   #:use-module (srfi srfi-26)
  40   #:export (crate->guix-package
  41             guix-package->crate-name
  42             %crate-updater))
  43
  44 \f
  45 ;;;
  46 ;;; Interface to https://crates.io/api/v1.
  47 ;;;
  48
  49 ;; Crates.  A crate is essentially a "package".  It can have several
  50 ;; "versions", each of which has its own set of dependencies, license,
  51 ;; etc.--see <crate-version> below.
  52 (define-json-mapping <crate> make-crate crate?
  53   json->crate
  54   (name          crate-name)                      ;string
  55   (latest-version crate-latest-version "max_version") ;string
  56   (home-page     crate-home-page "homepage")      ;string | #nil
  57   (repository    crate-repository)                ;string
  58   (description   crate-description)               ;string
  59   (keywords      crate-keywords                   ;list of strings
  60                  "keywords" vector->list)
  61   (categories    crate-categories                 ;list of strings
  62                  "categories" vector->list)
  63   (versions      crate-versions "actual_versions" ;list of <crate-version>
  64                  (lambda (vector)
  65                    (map json->crate-version
  66                         (vector->list vector))))
  67   (links         crate-links))                    ;alist
  68
  69 ;; Crate version.
  70 (define-json-mapping <crate-version> make-crate-version crate-version?
  71   json->crate-version
  72   (id            crate-version-id)                ;integer
  73   (number        crate-version-number "num")      ;string
  74   (download-path crate-version-download-path "dl_path") ;string
  75   (readme-path   crate-version-readme-path "readme_path") ;string
  76   (license       crate-version-license "license") ;string
  77   (links         crate-version-links))            ;alist
  78
  79 ;; Crate dependency.  Each dependency (each edge in the graph) is annotated as
  80 ;; being a "normal" dependency or a development dependency.  There also
  81 ;; information about the minimum required version, such as "^0.0.41".
  82 (define-json-mapping <crate-dependency> make-crate-dependency
  83   crate-dependency?
  84   json->crate-dependency
  85   (id            crate-dependency-id "crate_id")  ;string
  86   (kind          crate-dependency-kind "kind"     ;'normal | 'dev
  87                  string->symbol)
  88   (requirement   crate-dependency-requirement "req")) ;string
  89
  90 (define (lookup-crate name)
  91   "Look up NAME on https://crates.io and return the corresopnding <crate>
  92 record or #f if it was not found."
  93   (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
  94                                          name))))
  95     (and=> (and json (assoc-ref json "crate"))
  96            (lambda (alist)
  97              ;; The "versions" field of ALIST is simply a list of version IDs
  98              ;; (integers).  Here, we squeeze in the actual version
  99              ;; dictionaries that are not part of ALIST but are just more
 100              ;; convenient handled this way.
 101              (let ((versions (or (assoc-ref json "versions") '#())))
 102                (json->crate `(,@alist
 103                               ("actual_versions" . ,versions))))))))
 104
 105 (define (crate-version-dependencies version)
 106   "Return the list of <crate-dependency> records of VERSION, a
 107 <crate-version>."
 108   (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
 109          (url  (string-append (%crate-base-url) path)))
 110     (match (assoc-ref (or (json-fetch url) '()) "dependencies")
 111       ((? vector? vector)
 112        (map json->crate-dependency (vector->list vector)))
 113       (_
 114        '()))))
 115
 116 \f
 117 ;;;
 118 ;;; Converting crates to Guix packages.
 119 ;;;
 120
 121 (define (maybe-cargo-inputs package-names)
 122   (match (package-names->package-inputs package-names)
 123     (()
 124      '())
 125     ((package-inputs ...)
 126      `(#:cargo-inputs ,package-inputs))))
 127
 128 (define (maybe-cargo-development-inputs package-names)
 129   (match (package-names->package-inputs package-names)
 130     (()
 131      '())
 132     ((package-inputs ...)
 133      `(#:cargo-development-inputs ,package-inputs))))
 134
 135 (define (maybe-arguments arguments)
 136   (match arguments
 137     (()
 138      '())
 139     ((args ...)
 140      `((arguments (,'quasiquote ,args))))))
 141
 142 (define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
 143                           home-page synopsis description license
 144                           #:allow-other-keys)
 145   "Return the `package' s-expression for a rust package with the given NAME,
 146 VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
 147 and LICENSE."
 148   (let* ((port (http-fetch (crate-uri name version)))
 149          (guix-name (crate-name->package-name name))
 150          (cargo-inputs (map crate-name->package-name cargo-inputs))
 151          (cargo-development-inputs (map crate-name->package-name
 152                                         cargo-development-inputs))
 153          (pkg `(package
 154                    (name ,guix-name)
 155                    (version ,version)
 156                    (source (origin
 157                              (method url-fetch)
 158                              (uri (crate-uri ,name version))
 159                              (file-name (string-append name "-" version ".tar.gz"))
 160                              (sha256
 161                               (base32
 162                                ,(bytevector->nix-base32-string (port-sha256 port))))))
 163                    (build-system cargo-build-system)
 164                    ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
 165                                               (maybe-cargo-development-inputs
 166                                                 cargo-development-inputs)))
 167                    (home-page ,(match home-page
 168                                  (() "")
 169                                  (_ home-page)))
 170                    (synopsis ,synopsis)
 171                    (description ,(beautify-description description))
 172                    (license ,(match license
 173                                (() #f)
 174                                ((license) license)
 175                                (_ `(list ,@license)))))))
 176          (close-port port)
 177          pkg))
 178
 179 (define %dual-license-rx
 180   ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0".
 181   ;; This regexp matches that.
 182   (make-regexp "^(.*) OR (.*)$"))
 183
 184 (define (crate->guix-package crate-name)
 185   "Fetch the metadata for CRATE-NAME from crates.io, and return the
 186 `package' s-expression corresponding to that package, or #f on failure."
 187   (define (string->license string)
 188     (match (regexp-exec %dual-license-rx string)
 189       (#f (list (spdx-string->license string)))
 190       (m  (list (spdx-string->license (match:substring m 1))
 191                 (spdx-string->license (match:substring m 2))))))
 192
 193   (define (normal-dependency? dependency)
 194     (eq? (crate-dependency-kind dependency) 'normal))
 195
 196   (define crate
 197     (lookup-crate crate-name))
 198
 199   (and crate
 200        (let* ((version        (find (lambda (version)
 201                                       (string=? (crate-version-number version)
 202                                                 (crate-latest-version crate)))
 203                                     (crate-versions crate)))
 204               (dependencies   (crate-version-dependencies version))
 205               (dep-crates     (filter normal-dependency? dependencies))
 206               (dev-dep-crates (remove normal-dependency? dependencies))
 207               (cargo-inputs   (sort (map crate-dependency-id dep-crates)
 208                                     string-ci<?))
 209               (cargo-development-inputs
 210                (sort (map crate-dependency-id dev-dep-crates)
 211                      string-ci<?)))
 212          (make-crate-sexp #:name crate-name
 213                           #:version (crate-version-number version)
 214                           #:cargo-inputs cargo-inputs
 215                           #:cargo-development-inputs cargo-development-inputs
 216                           #:home-page (or (crate-home-page crate)
 217                                           (crate-repository crate))
 218                           #:synopsis (crate-description crate)
 219                           #:description (crate-description crate)
 220                           #:license (and=> (crate-version-license version)
 221                                            string->license)))))
 222
 223 (define (guix-package->crate-name package)
 224   "Return the crate name of PACKAGE."
 225   (and-let* ((origin (package-source package))
 226              (uri (origin-uri origin))
 227              (crate-url? uri)
 228              (len (string-length crate-url))
 229              (path (xsubstring uri len))
 230              (parts (string-split path #\/)))
 231     (match parts
 232       ((name _ ...) name))))
 233
 234 (define (crate-name->package-name name)
 235   (string-append "rust-" (string-join (string-split name #\_) "-")))
 236
 237 \f
 238 ;;;
 239 ;;; Updater
 240 ;;;
 241
 242 (define (crate-package? package)
 243   "Return true if PACKAGE is a Rust crate from crates.io."
 244   (let ((source-url (and=> (package-source package) origin-uri))
 245         (fetch-method (and=> (package-source package) origin-method)))
 246     (and (eq? fetch-method download:url-fetch)
 247          (match source-url
 248            ((? string?)
 249             (crate-url? source-url))
 250            ((source-url ...)
 251             (any crate-url? source-url))))))
 252
 253 (define (latest-release package)
 254   "Return an <upstream-source> for the latest release of PACKAGE."
 255   (let* ((crate-name (guix-package->crate-name package))
 256          (crate      (lookup-crate crate-name))
 257          (version    (crate-latest-version crate))
 258          (url        (crate-uri crate-name version)))
 259     (upstream-source
 260      (package (package-name package))
 261      (version version)
 262      (urls (list url)))))
 263
 264 (define %crate-updater
 265   (upstream-updater
 266    (name 'crates)
 267    (description "Updater for crates.io packages")
 268    (pred crate-package?)
 269    (latest latest-release)))
 270