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-alist
  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                                          (assoc-ref* package "dependencies" "runtime")))
 134                 (dependencies (map (lambda (dep)
 135                                      (if (string=? dep "bundler")
 136                                          "bundler" ; special case, no prefix
 137                                          (ruby-package-name dep)))
 138                                    dependencies-names))
 139                 (licenses     (map string->license
 140                                    (assoc-ref package "licenses"))))
 141            (values (make-gem-sexp name version hash home-page synopsis
 142                                   description dependencies licenses)
 143                    dependencies-names)))))
 144
 145 (define (guix-package->gem-name package)
 146   "Given a PACKAGE built from rubygems.org, return the name of the
 147 package on RubyGems."
 148   (let ((source-url (and=> (package-source package) origin-uri)))
 149     ;; The URL has the form:
 150     ;; 'https://rubygems.org/downloads/' +
 151     ;; package name + '-' + version + '.gem'
 152     ;; e.g. "https://rubygems.org/downloads/hashery-2.1.1.gem"
 153     (substring source-url 31 (string-rindex source-url #\-))))
 154
 155 (define (string->license str)
 156   "Convert the string STR into a license object."
 157   (match str
 158     ("GNU LGPL" license:lgpl2.0)
 159     ("GPL" license:gpl3)
 160     ((or "BSD" "BSD License") license:bsd-3)
 161     ((or "MIT" "MIT license" "Expat license") license:expat)
 162     ("Public domain" license:public-domain)
 163     ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0)
 164     (_ #f)))
 165
 166 (define (gem-package? package)
 167   "Return true if PACKAGE is a gem package from RubyGems."
 168
 169   (define (rubygems-url? url)
 170     (string-prefix? "https://rubygems.org/downloads/" url))
 171
 172   (let ((source-url (and=> (package-source package) origin-uri))
 173         (fetch-method (and=> (package-source package) origin-method)))
 174     (and (eq? fetch-method download:url-fetch)
 175          (match source-url
 176            ((? string?)
 177             (rubygems-url? source-url))
 178            ((source-url ...)
 179             (any rubygems-url? source-url))))))
 180
 181 (define (latest-release package)
 182   "Return an <upstream-source> for the latest release of PACKAGE."
 183   (let* ((gem-name (guix-package->gem-name package))
 184          (metadata (rubygems-fetch gem-name))
 185          (version (assoc-ref metadata "version"))
 186          (url (rubygems-uri gem-name version)))
 187     (upstream-source
 188      (package (package-name package))
 189      (version version)
 190      (urls (list url)))))
 191
 192 (define %gem-updater
 193   (upstream-updater
 194    (name 'gem)
 195    (description "Updater for RubyGem packages")
 196    (pred gem-package?)
 197    (latest latest-release)))
 198
 199 (define* (gem-recursive-import package-name #:optional version)
 200   (recursive-import package-name '()
 201                     #:repo->guix-package gem->guix-package
 202                     #:guix-name ruby-package-name))