guix/import/gem.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
   4 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
   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 gem)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 pretty-print)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (rnrs bytevectors)
  26   #:use-module (json)
  27   #:use-module (web uri)
  28   #:use-module ((guix download) #:prefix download:)
  29   #:use-module (guix import utils)
  30   #:use-module (guix import json)
  31   #:use-module (guix packages)
  32   #:use-module (guix upstream)
  33   #:use-module ((guix licenses) #:prefix license:)
  34   #:use-module (guix base32)
  35   #:use-module (guix build-system ruby)
  36   #:export (gem->guix-package
  37             %gem-updater
  38             gem-recursive-import))
  39
  40 (define (rubygems-fetch name)
  41   "Return an alist representation of the RubyGems metadata for the package NAME,
  42 or #f on failure."
  43   (json-fetch
  44    (string-append "https://rubygems.org/api/v1/gems/" name ".json")))
  45
  46 (define (ruby-package-name name)
  47   "Given the NAME of a package on RubyGems, return a Guix-compliant name for
  48 the package."
  49   (if (string-prefix? "ruby-" name)
  50       (snake-case name)
  51       (string-append "ruby-" (snake-case name))))
  52
  53 (define (hex-string->bytevector str)
  54   "Convert the hexadecimal encoded string STR to a bytevector."
  55   (define hex-char->int
  56     (match-lambda
  57      (#\0 0)
  58      (#\1 1)
  59      (#\2 2)
  60      (#\3 3)
  61      (#\4 4)
  62      (#\5 5)
  63      (#\6 6)
  64      (#\7 7)
  65      (#\8 8)
  66      (#\9 9)
  67      (#\a 10)
  68      (#\b 11)
  69      (#\c 12)
  70      (#\d 13)
  71      (#\e 14)
  72      (#\f 15)))
  73
  74   (define (read-byte i)
  75     (let ((j (* 2 i)))
  76       (+ (hex-char->int (string-ref str (1+ j)))
  77          (* (hex-char->int (string-ref str j)) 16))))
  78
  79   (let* ((len (/ (string-length str) 2))
  80          (bv  (make-bytevector len)))
  81     (let loop ((i 0))
  82       (if (= i len)
  83           bv
  84           (begin
  85             (bytevector-u8-set! bv i (read-byte i))
  86             (loop (1+ i)))))))
  87
  88 (define (make-gem-sexp name version hash home-page synopsis description
  89                        dependencies licenses)
  90   "Return the `package' s-expression for a Ruby package with the given NAME,
  91 VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
  92   `(package
  93      (name ,(ruby-package-name name))
  94      (version ,version)
  95      (source (origin
  96                (method url-fetch)
  97                (uri (rubygems-uri ,name version))
  98                (sha256
  99                 (base32
 100                  ,(bytevector->nix-base32-string
 101                    (hex-string->bytevector hash))))))
 102      (build-system ruby-build-system)
 103      ,@(if (null? dependencies)
 104            '()
 105            `((propagated-inputs
 106               (,'quasiquote
 107                ,(map (lambda (name)
 108                        `(,name
 109                          (,'unquote
 110                           ,(string->symbol name))))
 111                      dependencies)))))
 112      (synopsis ,synopsis)
 113      (description ,description)
 114      (home-page ,home-page)
 115      (license ,(match licenses
 116                  (() #f)
 117                  ((license) (license->symbol license))
 118                  (_ `(list ,@(map license->symbol licenses)))))))
 119
 120 (define* (gem->guix-package package-name #:optional (repo 'rubygems) version)
 121   "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the
 122 `package' s-expression corresponding to that package, or #f on failure."
 123   (let ((package (rubygems-fetch package-name)))
 124     (and package
 125          (let* ((name         (assoc-ref package "name"))
 126                 (version      (assoc-ref package "version"))
 127                 (hash         (assoc-ref package "sha"))
 128                 (synopsis     (assoc-ref package "info")) ; nothing better to use
 129                 (description  (beautify-description
 130                                (assoc-ref package "info")))
 131                 (home-page    (assoc-ref package "homepage_uri"))
 132                 (dependencies-names (map (lambda (dep) (assoc-ref dep "name"))
 133                                          (vector->list
 134                                           (assoc-ref* package
 135                                                       "dependencies"
 136                                                       "runtime"))))
 137                 (dependencies (map (lambda (dep)
 138                                      (if (string=? dep "bundler")
 139                                          "bundler" ; special case, no prefix
 140                                          (ruby-package-name dep)))
 141                                    dependencies-names))
 142                 (licenses     (map string->license
 143                                    (vector->list
 144                                     (assoc-ref package "licenses")))))
 145            (values (make-gem-sexp name version hash home-page synopsis
 146                                   description dependencies licenses)
 147                    dependencies-names)))))
 148
 149 (define (guix-package->gem-name package)
 150   "Given a PACKAGE built from rubygems.org, return the name of the
 151 package on RubyGems."
 152   (let ((source-url (and=> (package-source package) origin-uri)))
 153     ;; The URL has the form:
 154     ;; 'https://rubygems.org/downloads/' +
 155     ;; package name + '-' + version + '.gem'
 156     ;; e.g. "https://rubygems.org/downloads/hashery-2.1.1.gem"
 157     (substring source-url 31 (string-rindex source-url #\-))))
 158
 159 (define (string->license str)
 160   "Convert the string STR into a license object."
 161   (match str
 162     ("GNU LGPL" license:lgpl2.0)
 163     ("GPL" license:gpl3)
 164     ((or "BSD" "BSD License") license:bsd-3)
 165     ((or "MIT" "MIT license" "Expat license") license:expat)
 166     ("Public domain" license:public-domain)
 167     ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0)
 168     (_ #f)))
 169
 170 (define (gem-package? package)
 171   "Return true if PACKAGE is a gem package from RubyGems."
 172
 173   (define (rubygems-url? url)
 174     (string-prefix? "https://rubygems.org/downloads/" url))
 175
 176   (let ((source-url (and=> (package-source package) origin-uri))
 177         (fetch-method (and=> (package-source package) origin-method)))
 178     (and (eq? fetch-method download:url-fetch)
 179          (match source-url
 180            ((? string?)
 181             (rubygems-url? source-url))
 182            ((source-url ...)
 183             (any rubygems-url? source-url))))))
 184
 185 (define (latest-release package)
 186   "Return an <upstream-source> for the latest release of PACKAGE."
 187   (let* ((gem-name (guix-package->gem-name package))
 188          (metadata (rubygems-fetch gem-name))
 189          (version (assoc-ref metadata "version"))
 190          (url (rubygems-uri gem-name version)))
 191     (upstream-source
 192      (package (package-name package))
 193      (version version)
 194      (urls (list url)))))
 195
 196 (define %gem-updater
 197   (upstream-updater
 198    (name 'gem)
 199    (description "Updater for RubyGem packages")
 200    (pred gem-package?)
 201    (latest latest-release)))
 202
 203 (define* (gem-recursive-import package-name #:optional version)
 204   (recursive-import package-name '()
 205                     #:repo->guix-package gem->guix-package
 206                     #:guix-name ruby-package-name))