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