guix/import/cpan.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.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 cpan)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 regex)
  23   #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
  24   #:use-module ((ice-9 rdelim) #:select (read-line))
  25   #:use-module (srfi srfi-1)
  26   #:use-module (json)
  27   #:use-module (guix hash)
  28   #:use-module (guix store)
  29   #:use-module (guix base32)
  30   #:use-module ((guix download) #:select (download-to-store))
  31   #:use-module (guix import utils)
  32   #:use-module (guix import json)
  33   #:use-module (guix packages)
  34   #:use-module (guix derivations)
  35   #:use-module (gnu packages perl)
  36   #:export (cpan->guix-package))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; Generate a package declaration template for the latest version of a CPAN
  41 ;;; module, using meta-data from metacpan.org.
  42 ;;;
  43 ;;; Code:
  44
  45 (define string->license
  46   (match-lambda
  47    ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
  48    ;; Some licenses are excluded based on their absense from (guix licenses).
  49    ("agpl_3" 'agpl3)
  50    ;; apache_1_1
  51    ("apache_2_0" 'asl2.0)
  52    ;; artistic_1
  53    ("artistic_2" 'artistic2.0)
  54    ("bsd" 'bsd-3)
  55    ("freebsd" 'bsd-2)
  56    ;; gfdl_1_2
  57    ("gfdl_1_3" 'fdl1.3+)
  58    ("gpl_1" 'gpl1)
  59    ("gpl_2" 'gpl2)
  60    ("gpl_3" 'gpl3)
  61    ("lgpl_2_1" 'lgpl2.1)
  62    ("lgpl_3_0" 'lgpl3)
  63    ("mit" 'x11)
  64    ;; mozilla_1_0
  65    ("mozilla_1_1" 'mpl1.1)
  66    ("openssl" 'openssl)
  67    ("perl_5" '(package-license perl))   ;GPL1+ and Artistic 1
  68    ("qpl_1_0" 'qpl)
  69    ;; ssleay
  70    ;; sun
  71    ("zlib" 'zlib)
  72    ((x) (string->license x))
  73    ((lst ...) `(list ,@(map string->license lst)))
  74    (_ #f)))
  75
  76 (define (module->name module)
  77   "Transform a 'module' name into a 'release' name"
  78   (regexp-substitute/global #f "::" module 'pre "-" 'post))
  79
  80 (define (module->dist-name module)
  81   "Return the base distribution module for a given module.  E.g. the 'ok'
  82 module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
  83 return \"Test-Simple\""
  84   (assoc-ref (json-fetch (string-append "http://api.metacpan.org/module/"
  85                                         module))
  86              "distribution"))
  87
  88 (define (cpan-fetch module)
  89   "Return an alist representation of the CPAN metadata for the perl module MODULE,
  90 or #f on failure.  MODULE should be e.g. \"Test::Script\""
  91   ;; This API always returns the latest release of the module.
  92   (json-fetch (string-append "http://api.metacpan.org/release/"
  93                              ;; XXX: The 'release' api requires the "release"
  94                              ;; name of the package.  This substitution seems
  95                              ;; reasonably consistent across packages.
  96                              (module->name module))))
  97
  98 (define (cpan-home name)
  99   (string-append "http://search.cpan.org/dist/" name))
 100
 101 (define %corelist
 102   (delay
 103     (let* ((perl (with-store store
 104                    (derivation->output-path
 105                     (package-derivation store perl))))
 106            (core (string-append perl "/bin/corelist")))
 107       (and (access? core X_OK)
 108            core))))
 109
 110 (define (cpan-module->sexp meta)
 111   "Return the `package' s-expression for a CPAN module from the metadata in
 112 META."
 113   (define name
 114     (assoc-ref meta "distribution"))
 115
 116   (define (guix-name name)
 117     (if (string-prefix? "perl-" name)
 118         (string-downcase name)
 119         (string-append "perl-" (string-downcase name))))
 120
 121   (define version
 122     (assoc-ref meta "version"))
 123
 124   (define (core-module? name)
 125     (and (force %corelist)
 126          (parameterize ((current-error-port (%make-void-port "w")))
 127            (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
 128              (let loop ((line (read-line corelist)))
 129                (if (eof-object? line)
 130                    (begin (close-pipe corelist) #f)
 131                    (if (string-contains line "first released with perl")
 132                        (begin (close-pipe corelist) #t)
 133                        (loop (read-line corelist)))))))))
 134
 135   (define (convert-inputs phases)
 136     ;; Convert phase dependencies into a list of name/variable pairs.
 137     (match (flatten
 138             (map (lambda (ph)
 139                    (filter-map (lambda (t)
 140                                  (assoc-ref* meta "metadata" "prereqs" ph t))
 141                                '("requires" "recommends" "suggests")))
 142                  phases))
 143       (#f
 144        '())
 145       ((inputs ...)
 146        (sort
 147         (delete-duplicates
 148          ;; Listed dependencies may include core modules.  Filter those out.
 149          (filter-map (match-lambda
 150                       (("perl" . _)     ;implicit dependency
 151                        #f)
 152                       ((module . _)
 153                        (and (not (core-module? module))
 154                             (let ((name (guix-name (module->dist-name module))))
 155                               (list name
 156                                     (list 'unquote (string->symbol name)))))))
 157                      inputs))
 158         (lambda args
 159           (match args
 160             (((a _ ...) (b _ ...))
 161              (string<? a b))))))))
 162
 163   (define (maybe-inputs guix-name inputs)
 164     (match inputs
 165       (()
 166        '())
 167       ((inputs ...)
 168        (list (list guix-name
 169                    (list 'quasiquote inputs))))))
 170
 171   (define source-url
 172     (regexp-substitute/global #f "http://cpan.metacpan.org"
 173                               (assoc-ref meta "download_url")
 174                               'pre "mirror://cpan" 'post))
 175
 176   (let ((tarball (with-store store
 177                    (download-to-store store source-url))))
 178     `(package
 179        (name ,(guix-name name))
 180        (version ,version)
 181        (source (origin
 182                  (method url-fetch)
 183                  (uri (string-append ,@(factorize-uri source-url version)))
 184                  (sha256
 185                   (base32
 186                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
 187        (build-system perl-build-system)
 188        ,@(maybe-inputs 'native-inputs
 189                        ;; "runtime" may also be needed here.  See
 190                        ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
 191                        ;; which says they are required during building.  We
 192                        ;; have not yet had a need for cross-compiled perl
 193                        ;; modules, however, so we leave it out.
 194                        (convert-inputs '("configure" "build" "test")))
 195        ,@(maybe-inputs 'inputs
 196                        (convert-inputs '("runtime")))
 197        (home-page ,(string-append "http://search.cpan.org/dist/" name))
 198        (synopsis ,(assoc-ref meta "abstract"))
 199        (description fill-in-yourself!)
 200        (license ,(string->license (assoc-ref meta "license"))))))
 201
 202 (define (cpan->guix-package module-name)
 203   "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
 204 `package' s-expression corresponding to that package, or #f on failure."
 205   (let ((module-meta (cpan-fetch module-name)))
 206     (and=> module-meta cpan-module->sexp)))