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, 2018 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 (gcrypt 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-alist (string-append
  92                                 "https://fastapi.metacpan.org/v1/module/"
  93                                 module
  94                                 "?fields=distribution"))
  95              "distribution"))
  96
  97 (define (package->upstream-name package)
  98   "Return the CPAN name of PACKAGE."
  99   (let* ((properties (package-properties package))
 100          (upstream-name (and=> properties
 101                                (cut assoc-ref <> 'upstream-name))))
 102     (or upstream-name
 103         (match (package-source package)
 104           ((? origin? origin)
 105            (match (origin-uri origin)
 106              ((or (? string? url) (url _ ...))
 107               (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
 108                 (#f #f)
 109                 (m (match:substring m 1))))
 110              (_ #f)))
 111           (_ #f)))))
 112
 113 (define (cpan-fetch name)
 114   "Return an alist representation of the CPAN metadata for the perl module MODULE,
 115 or #f on failure.  MODULE should be e.g. \"Test::Script\""
 116   ;; This API always returns the latest release of the module.
 117   (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
 118
 119 (define (cpan-home name)
 120   (string-append "https://metacpan.org/release/" name))
 121
 122 (define (cpan-source-url meta)
 123   "Return the download URL for a module's source tarball."
 124   (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
 125                             (assoc-ref meta "download_url")
 126                             'pre "mirror://cpan" 'post))
 127
 128 (define (cpan-version meta)
 129   "Return the version number from META."
 130   (match (assoc-ref meta "version")
 131     ((? number? version)
 132      ;; version is sometimes not quoted in the module json, so it gets
 133      ;; imported into Guile as a number, so convert it to a string.
 134      (number->string version))
 135     (version
 136      ;; Sometimes we get a "v" prefix.  Strip it.
 137      (if (string-prefix? "v" version)
 138          (string-drop version 1)
 139          version))))
 140
 141 (define (perl-package)
 142   "Return the 'perl' package.  This is a lazy reference so that we don't
 143 depend on (gnu packages perl)."
 144   (module-ref (resolve-interface '(gnu packages perl)) 'perl))
 145
 146 (define %corelist
 147   (delay
 148     (let* ((perl (with-store store
 149                    (derivation->output-path
 150                     (package-derivation store (perl-package)))))
 151            (core (string-append perl "/bin/corelist")))
 152       (and (access? core X_OK)
 153            core))))
 154
 155 (define core-module?
 156   (let ((rx (make-regexp
 157              (string-append "released with perl v?([0-9\\.]*)"
 158                             "(.*and removed from v?([0-9\\.]*))?"))))
 159     (lambda (name)
 160       (define perl-version
 161         (package-version (perl-package)))
 162
 163       (define (version-between? lower version upper)
 164         (and (version>=? version lower)
 165              (or (not upper)
 166                  (version>? upper version))))
 167       (and (force %corelist)
 168            (parameterize ((current-error-port (%make-void-port "w")))
 169              (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
 170                (let loop ()
 171                  (let ((line (read-line corelist)))
 172                    (if (eof-object? line)
 173                        (begin (close-pipe corelist) #f)
 174                        (or (and=> (regexp-exec rx line)
 175                                   (lambda (m)
 176                                     (let ((first (match:substring m 1))
 177                                           (last  (match:substring m 3)))
 178                                       (version-between?
 179                                        first perl-version last))))
 180                            (loop)))))))))))
 181
 182 (define (cpan-module->sexp meta)
 183   "Return the `package' s-expression for a CPAN module from the metadata in
 184 META."
 185   (define name
 186     (assoc-ref meta "distribution"))
 187
 188   (define (guix-name name)
 189     (if (string-prefix? "perl-" name)
 190         (string-downcase name)
 191         (string-append "perl-" (string-downcase name))))
 192
 193   (define version (cpan-version meta))
 194   (define source-url (cpan-source-url meta))
 195
 196   (define (convert-inputs phases)
 197     ;; Convert phase dependencies into a list of name/variable pairs.
 198     (match (flatten
 199             (map (lambda (ph)
 200                    (filter-map (lambda (t)
 201                                  (assoc-ref* meta "metadata" "prereqs" ph t))
 202                                '("requires" "recommends" "suggests")))
 203                  phases))
 204       (#f
 205        '())
 206       ((inputs ...)
 207        (sort
 208         (delete-duplicates
 209          ;; Listed dependencies may include core modules.  Filter those out.
 210          (filter-map (match-lambda
 211                       (("perl" . _)     ;implicit dependency
 212                        #f)
 213                       ((module . _)
 214                        (and (not (core-module? module))
 215                             (let ((name (guix-name (module->dist-name module))))
 216                               (list name
 217                                     (list 'unquote (string->symbol name)))))))
 218                      inputs))
 219         (lambda args
 220           (match args
 221             (((a _ ...) (b _ ...))
 222              (string<? a b))))))))
 223
 224   (define (maybe-inputs guix-name inputs)
 225     (match inputs
 226       (()
 227        '())
 228       ((inputs ...)
 229        (list (list guix-name
 230                    (list 'quasiquote inputs))))))
 231
 232   (let ((tarball (with-store store
 233                    (download-to-store store source-url))))
 234     `(package
 235        (name ,(guix-name name))
 236        (version ,version)
 237        (source (origin
 238                  (method url-fetch)
 239                  (uri (string-append ,@(factorize-uri source-url version)))
 240                  (sha256
 241                   (base32
 242                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
 243        (build-system perl-build-system)
 244        ,@(maybe-inputs 'native-inputs
 245                        ;; "runtime" may also be needed here.  See
 246                        ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
 247                        ;; which says they are required during building.  We
 248                        ;; have not yet had a need for cross-compiled perl
 249                        ;; modules, however, so we leave it out.
 250                        (convert-inputs '("configure" "build" "test")))
 251        ,@(maybe-inputs 'propagated-inputs
 252                        (convert-inputs '("runtime")))
 253        (home-page ,(cpan-home name))
 254        (synopsis ,(assoc-ref meta "abstract"))
 255        (description fill-in-yourself!)
 256        (license ,(string->license (assoc-ref meta "license"))))))
 257
 258 (define (cpan->guix-package module-name)
 259   "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
 260 `package' s-expression corresponding to that package, or #f on failure."
 261   (let ((module-meta (cpan-fetch (module->name module-name))))
 262     (and=> module-meta cpan-module->sexp)))
 263
 264 (define (cpan-package? package)
 265   "Return #t if PACKAGE is a package from CPAN."
 266   (define cpan-url?
 267     (let ((cpan-rx (make-regexp (string-append "("
 268                                                "mirror://cpan" "|"
 269                                                "https?://www.cpan.org" "|"
 270                                                "https?://cpan.metacpan.org"
 271                                                ")"))))
 272       (lambda (url)
 273         (regexp-exec cpan-rx url))))
 274
 275   (let ((source-url (and=> (package-source package) origin-uri))
 276         (fetch-method (and=> (package-source package) origin-method)))
 277     (and (eq? fetch-method url-fetch)
 278          (match source-url
 279            ((? string?)
 280             (cpan-url? source-url))
 281            ((source-url ...)
 282             (any cpan-url? source-url))))))
 283
 284 (define (latest-release package)
 285   "Return an <upstream-source> for the latest release of PACKAGE."
 286   (match (cpan-fetch (package->upstream-name package))
 287     (#f #f)
 288     (meta
 289      (let ((core-inputs
 290             (match (package-direct-inputs package)
 291               (((_ inputs _ ...) ...)
 292                (filter-map (match-lambda
 293                              ((and (? package?)
 294                                    (? cpan-package?)
 295                                    (= package->upstream-name
 296                                       (? core-module? name)))
 297                               name)
 298                              (else #f))
 299                            inputs)))))
 300        ;; Warn about inputs that are part of perl's core
 301        (unless (null? core-inputs)
 302          (for-each (lambda (module)
 303                      (warning (G_ "input '~a' of ~a is in Perl core~%")
 304                               module (package-name package)))
 305                    core-inputs)))
 306      (let ((version (cpan-version meta))
 307            (url (cpan-source-url meta)))
 308        (upstream-source
 309         (package (package-name package))
 310         (version version)
 311         (urls (list url)))))))
 312
 313 (define %cpan-updater
 314   (upstream-updater
 315    (name 'cpan)
 316    (description "Updater for CPAN packages")
 317    (pred cpan-package?)
 318    (latest latest-release)))