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 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix import cpan)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 regex)
  25   #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
  26   #:use-module ((ice-9 rdelim) #:select (read-line))
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (json)
  30   #:use-module (guix hash)
  31   #:use-module (guix store)
  32   #:use-module (guix utils)
  33   #:use-module (guix base32)
  34   #:use-module (guix ui)
  35   #:use-module ((guix download) #:select (download-to-store url-fetch))
  36   #:use-module ((guix import utils) #:select (factorize-uri
  37                                               flatten assoc-ref*))
  38   #:use-module (guix import json)
  39   #:use-module (guix packages)
  40   #:use-module (guix upstream)
  41   #:use-module (guix derivations)
  42   #:export (cpan->guix-package
  43             %cpan-updater))
  44
  45 ;;; Commentary:
  46 ;;;
  47 ;;; Generate a package declaration template for the latest version of a CPAN
  48 ;;; module, using meta-data from metacpan.org.
  49 ;;;
  50 ;;; Code:
  51
  52 (define string->license
  53   (match-lambda
  54    ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
  55    ;; Some licenses are excluded based on their absense from (guix licenses).
  56    ("agpl_3" 'agpl3)
  57    ;; apache_1_1
  58    ("apache_2_0" 'asl2.0)
  59    ;; artistic_1
  60    ("artistic_2" 'artistic2.0)
  61    ("bsd" 'bsd-3)
  62    ("freebsd" 'bsd-2)
  63    ;; gfdl_1_2
  64    ("gfdl_1_3" 'fdl1.3+)
  65    ("gpl_1" 'gpl1)
  66    ("gpl_2" 'gpl2)
  67    ("gpl_3" 'gpl3)
  68    ("lgpl_2_1" 'lgpl2.1)
  69    ("lgpl_3_0" 'lgpl3)
  70    ("mit" 'x11)
  71    ;; mozilla_1_0
  72    ("mozilla_1_1" 'mpl1.1)
  73    ("openssl" 'openssl)
  74    ("perl_5" 'perl-license)   ;GPL1+ and Artistic 1
  75    ("qpl_1_0" 'qpl)
  76    ;; ssleay
  77    ;; sun
  78    ("zlib" 'zlib)
  79    ((x) (string->license x))
  80    ((lst ...) `(list ,@(map string->license lst)))
  81    (_ #f)))
  82
  83 (define (module->name module)
  84   "Transform a 'module' name into a 'release' name"
  85   (regexp-substitute/global #f "::" module 'pre "-" 'post))
  86
  87 (define (module->dist-name module)
  88   "Return the base distribution module for a given module.  E.g. the 'ok'
  89 module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
  90 return \"Test-Simple\""
  91   (assoc-ref (json-fetch (string-append "https://fastapi.metacpan.org/v1/module/"
  92                                         module
  93                                         "?fields=distribution"))
  94              "distribution"))
  95
  96 (define (package->upstream-name package)
  97   "Return the CPAN name of PACKAGE."
  98   (let* ((properties (package-properties package))
  99          (upstream-name (and=> properties
 100                                (cut assoc-ref <> 'upstream-name))))
 101     (or upstream-name
 102         (match (package-source package)
 103           ((? origin? origin)
 104            (match (origin-uri origin)
 105              ((or (? string? url) (url _ ...))
 106               (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
 107                 (#f #f)
 108                 (m (match:substring m 1))))
 109              (_ #f)))
 110           (_ #f)))))
 111
 112 (define (cpan-fetch name)
 113   "Return an alist representation of the CPAN metadata for the perl module MODULE,
 114 or #f on failure.  MODULE should be e.g. \"Test::Script\""
 115   ;; This API always returns the latest release of the module.
 116   (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
 117
 118 (define (cpan-home name)
 119   (string-append "http://search.cpan.org/dist/" name "/"))
 120
 121 (define (cpan-source-url meta)
 122   "Return the download URL for a module's source tarball."
 123   (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
 124                             (assoc-ref meta "download_url")
 125                             'pre "mirror://cpan" 'post))
 126
 127 (define (cpan-version meta)
 128   "Return the version number from META."
 129   (match (assoc-ref meta "version")
 130     ((? number? version)
 131      ;; version is sometimes not quoted in the module json, so it gets
 132      ;; imported into Guile as a number, so convert it to a string.
 133      (number->string version))
 134     (version version)))
 135
 136 (define (perl-package)
 137   "Return the 'perl' package.  This is a lazy reference so that we don't
 138 depend on (gnu packages perl)."
 139   (module-ref (resolve-interface '(gnu packages perl)) 'perl))
 140
 141 (define %corelist
 142   (delay
 143     (let* ((perl (with-store store
 144                    (derivation->output-path
 145                     (package-derivation store (perl-package)))))
 146            (core (string-append perl "/bin/corelist")))
 147       (and (access? core X_OK)
 148            core))))
 149
 150 (define core-module?
 151   (let ((rx (make-regexp
 152              (string-append "released with perl v?([0-9\\.]*)"
 153                             "(.*and removed from v?([0-9\\.]*))?"))))
 154     (lambda (name)
 155       (define perl-version
 156         (package-version (perl-package)))
 157
 158       (define (version-between? lower version upper)
 159         (and (version>=? version lower)
 160              (or (not upper)
 161                  (version>? upper version))))
 162       (and (force %corelist)
 163            (parameterize ((current-error-port (%make-void-port "w")))
 164              (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
 165                (let loop ()
 166                  (let ((line (read-line corelist)))
 167                    (if (eof-object? line)
 168                        (begin (close-pipe corelist) #f)
 169                        (or (and=> (regexp-exec rx line)
 170                                   (lambda (m)
 171                                     (let ((first (match:substring m 1))
 172                                           (last  (match:substring m 3)))
 173                                       (version-between?
 174                                        first perl-version last))))
 175                            (loop)))))))))))
 176
 177 (define (cpan-module->sexp meta)
 178   "Return the `package' s-expression for a CPAN module from the metadata in
 179 META."
 180   (define name
 181     (assoc-ref meta "distribution"))
 182
 183   (define (guix-name name)
 184     (if (string-prefix? "perl-" name)
 185         (string-downcase name)
 186         (string-append "perl-" (string-downcase name))))
 187
 188   (define version (cpan-version meta))
 189   (define source-url (cpan-source-url meta))
 190
 191   (define (convert-inputs phases)
 192     ;; Convert phase dependencies into a list of name/variable pairs.
 193     (match (flatten
 194             (map (lambda (ph)
 195                    (filter-map (lambda (t)
 196                                  (assoc-ref* meta "metadata" "prereqs" ph t))
 197                                '("requires" "recommends" "suggests")))
 198                  phases))
 199       (#f
 200        '())
 201       ((inputs ...)
 202        (sort
 203         (delete-duplicates
 204          ;; Listed dependencies may include core modules.  Filter those out.
 205          (filter-map (match-lambda
 206                       (("perl" . _)     ;implicit dependency
 207                        #f)
 208                       ((module . _)
 209                        (and (not (core-module? module))
 210                             (let ((name (guix-name (module->dist-name module))))
 211                               (list name
 212                                     (list 'unquote (string->symbol name)))))))
 213                      inputs))
 214         (lambda args
 215           (match args
 216             (((a _ ...) (b _ ...))
 217              (string<? a b))))))))
 218
 219   (define (maybe-inputs guix-name inputs)
 220     (match inputs
 221       (()
 222        '())
 223       ((inputs ...)
 224        (list (list guix-name
 225                    (list 'quasiquote inputs))))))
 226
 227   (let ((tarball (with-store store
 228                    (download-to-store store source-url))))
 229     `(package
 230        (name ,(guix-name name))
 231        (version ,version)
 232        (source (origin
 233                  (method url-fetch)
 234                  (uri (string-append ,@(factorize-uri source-url version)))
 235                  (sha256
 236                   (base32
 237                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
 238        (build-system perl-build-system)
 239        ,@(maybe-inputs 'native-inputs
 240                        ;; "runtime" may also be needed here.  See
 241                        ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
 242                        ;; which says they are required during building.  We
 243                        ;; have not yet had a need for cross-compiled perl
 244                        ;; modules, however, so we leave it out.
 245                        (convert-inputs '("configure" "build" "test")))
 246        ,@(maybe-inputs 'propagated-inputs
 247                        (convert-inputs '("runtime")))
 248        (home-page ,(cpan-home name))
 249        (synopsis ,(assoc-ref meta "abstract"))
 250        (description fill-in-yourself!)
 251        (license ,(string->license (assoc-ref meta "license"))))))
 252
 253 (define (cpan->guix-package module-name)
 254   "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
 255 `package' s-expression corresponding to that package, or #f on failure."
 256   (let ((module-meta (cpan-fetch (module->name module-name))))
 257     (and=> module-meta cpan-module->sexp)))
 258
 259 (define (cpan-package? package)
 260   "Return #t if PACKAGE is a package from CPAN."
 261   (define cpan-url?
 262     (let ((cpan-rx (make-regexp (string-append "("
 263                                                "mirror://cpan" "|"
 264                                                "https?://www.cpan.org" "|"
 265                                                "https?://cpan.metacpan.org"
 266                                                ")"))))
 267       (lambda (url)
 268         (regexp-exec cpan-rx url))))
 269
 270   (let ((source-url (and=> (package-source package) origin-uri))
 271         (fetch-method (and=> (package-source package) origin-method)))
 272     (and (eq? fetch-method url-fetch)
 273          (match source-url
 274            ((? string?)
 275             (cpan-url? source-url))
 276            ((source-url ...)
 277             (any cpan-url? source-url))))))
 278
 279 (define (latest-release package)
 280   "Return an <upstream-source> for the latest release of PACKAGE."
 281   (match (cpan-fetch (package->upstream-name package))
 282     (#f #f)
 283     (meta
 284      (let ((core-inputs
 285             (match (package-direct-inputs package)
 286               (((_ inputs _ ...) ...)
 287                (filter-map (match-lambda
 288                              ((and (? package?)
 289                                    (? cpan-package?)
 290                                    (= package->upstream-name
 291                                       (? core-module? name)))
 292                               name)
 293                              (else #f))
 294                            inputs)))))
 295        ;; Warn about inputs that are part of perl's core
 296        (unless (null? core-inputs)
 297          (for-each (lambda (module)
 298                      (warning (G_ "input '~a' of ~a is in Perl core~%")
 299                               module (package-name package)))
 300                    core-inputs)))
 301      (let ((version (cpan-version meta))
 302            (url (cpan-source-url meta)))
 303        (upstream-source
 304         (package (package-name package))
 305         (version version)
 306         (urls (list url)))))))
 307
 308 (define %cpan-updater
 309   (upstream-updater
 310    (name 'cpan)
 311    (description "Updater for CPAN packages")
 312    (pred cpan-package?)
 313    (latest latest-release)))