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