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, 2021 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-module
  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                   ((? unspecified?) #f)
 113                   ((lst ...) (assoc-ref lst "homepage"))))
 114   (dependencies cpan-release-dependencies "dependency"
 115                 (lambda (vector)
 116                   (map json->cpan-dependency (vector->list vector)))))
 117
 118 (define string->license
 119   (match-lambda
 120    ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
 121    ;; Some licenses are excluded based on their absense from (guix licenses).
 122    ("agpl_3" 'agpl3)
 123    ;; apache_1_1
 124    ("apache_2_0" 'asl2.0)
 125    ;; artistic_1
 126    ("artistic_2" 'artistic2.0)
 127    ("bsd" 'bsd-3)
 128    ("freebsd" 'bsd-2)
 129    ;; gfdl_1_2
 130    ("gfdl_1_3" 'fdl1.3+)
 131    ("gpl_1" 'gpl1)
 132    ("gpl_2" 'gpl2)
 133    ("gpl_3" 'gpl3)
 134    ("lgpl_2_1" 'lgpl2.1)
 135    ("lgpl_3_0" 'lgpl3)
 136    ("mit" 'x11)
 137    ;; mozilla_1_0
 138    ("mozilla_1_1" 'mpl1.1)
 139    ("openssl" 'openssl)
 140    ("perl_5" 'perl-license)   ;GPL1+ and Artistic 1
 141    ("qpl_1_0" 'qpl)
 142    ;; ssleay
 143    ;; sun
 144    ("zlib" 'zlib)
 145    (#(x) (string->license x))
 146    (#(lst ...) `(list ,@(map string->license lst)))
 147    (_ #f)))
 148
 149 (define (module->name module)
 150   "Transform a 'module' name into a 'release' name"
 151   (regexp-substitute/global #f "::" module 'pre "-" 'post))
 152
 153 (define (module->dist-name module)
 154   "Return the base distribution module for a given module.  E.g. the 'ok'
 155 module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
 156 return \"Test-Simple\""
 157   (assoc-ref (json-fetch (string-append
 158                           (%metacpan-base-url) "/module/"
 159                           module
 160                           "?fields=distribution"))
 161              "distribution"))
 162
 163 (define (package->upstream-name package)
 164   "Return the CPAN name of PACKAGE."
 165   (let* ((properties (package-properties package))
 166          (upstream-name (and=> properties
 167                                (cut assoc-ref <> 'upstream-name))))
 168     (or upstream-name
 169         (match (package-source package)
 170           ((? origin? origin)
 171            (match (origin-uri origin)
 172              ((or (? string? url) (url _ ...))
 173               (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
 174                 (#f #f)
 175                 (m (match:substring m 1))))
 176              (_ #f)))
 177           (_ #f)))))
 178
 179 (define (cpan-fetch name)
 180   "Return a <cpan-release> record for Perl module MODULE,
 181 or #f on failure.  MODULE should be the distribution name, such as
 182 \"Test-Script\" for the \"Test::Script\" module."
 183   ;; This API always returns the latest release of the module.
 184   (and=> (json-fetch (string-append (%metacpan-base-url) "/release/"
 185                                     name))
 186          json->cpan-release))
 187
 188 (define (cpan-home name)
 189   (string-append "https://metacpan.org/release/" name))
 190
 191 (define (metacpan-url->mirror-url url)
 192   "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
 193   (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
 194                             url
 195                             'pre "mirror://cpan" 'post))
 196
 197 (define cpan-source-url
 198   (compose metacpan-url->mirror-url cpan-release-download-url))
 199
 200 (define (perl-package)
 201   "Return the 'perl' package.  This is a lazy reference so that we don't
 202 depend on (gnu packages perl)."
 203   (module-ref (resolve-interface '(gnu packages perl)) 'perl))
 204
 205 (define %corelist
 206   (delay
 207     (let* ((perl (with-store store
 208                    (derivation->output-path
 209                     (package-derivation store (perl-package)))))
 210            (core (string-append perl "/bin/corelist")))
 211       (and (access? core X_OK)
 212            core))))
 213
 214 (define core-module?
 215   (let ((rx (make-regexp
 216              (string-append "released with perl v?([0-9\\.]*)"
 217                             "(.*and removed from v?([0-9\\.]*))?"))))
 218     (lambda (name)
 219       (define perl-version
 220         (package-version (perl-package)))
 221
 222       (define (version-between? lower version upper)
 223         (and (version>=? version lower)
 224              (or (not upper)
 225                  (version>? upper version))))
 226       (and (force %corelist)
 227            (parameterize ((current-error-port (%make-void-port "w")))
 228              (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
 229                (let loop ()
 230                  (let ((line (read-line corelist)))
 231                    (if (eof-object? line)
 232                        (begin (close-pipe corelist) #f)
 233                        (or (and=> (regexp-exec rx line)
 234                                   (lambda (m)
 235                                     (let ((first (match:substring m 1))
 236                                           (last  (match:substring m 3)))
 237                                       (version-between?
 238                                        first perl-version last))))
 239                            (loop)))))))))))
 240
 241 (define (cpan-module->sexp release)
 242   "Return the 'package' s-expression for a CPAN module from the release data
 243 in RELEASE, a <cpan-release> record."
 244   (define name
 245     (cpan-release-distribution release))
 246
 247   (define (guix-name name)
 248     (if (string-prefix? "perl-" name)
 249         (string-downcase name)
 250         (string-append "perl-" (string-downcase name))))
 251
 252   (define version (cpan-release-version release))
 253   (define source-url (cpan-source-url release))
 254
 255   (define (convert-inputs phases)
 256     ;; Convert phase dependencies into a list of name/variable pairs.
 257     (match (filter-map (lambda (dependency)
 258                          (and (memq (cpan-dependency-phase dependency)
 259                                     phases)
 260                               (cpan-dependency-module dependency)))
 261                        (cpan-release-dependencies release))
 262       ((inputs ...)
 263        (sort
 264         (delete-duplicates
 265          ;; Listed dependencies may include core modules.  Filter those out.
 266          (filter-map (match-lambda
 267                        ("perl" #f)                ;implicit dependency
 268                        ((? core-module?) #f)
 269                        (module
 270                          (let ((name (guix-name (module->dist-name module))))
 271                            (list name
 272                                  (list 'unquote (string->symbol name))))))
 273                      inputs))
 274         (lambda args
 275           (match args
 276             (((a _ ...) (b _ ...))
 277              (string<? a b))))))))
 278
 279   (define (maybe-inputs guix-name inputs)
 280     (match inputs
 281       (()
 282        '())
 283       ((inputs ...)
 284        (list (list guix-name
 285                    (list 'quasiquote inputs))))))
 286
 287   (let ((tarball (with-store store
 288                    (download-to-store store source-url))))
 289     `(package
 290        (name ,(guix-name name))
 291        (version ,version)
 292        (source (origin
 293                  (method url-fetch)
 294                  (uri (string-append ,@(factorize-uri source-url version)))
 295                  (sha256
 296                   (base32
 297                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
 298        (build-system perl-build-system)
 299        ,@(maybe-inputs 'native-inputs
 300                        ;; "runtime" may also be needed here.  See
 301                        ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
 302                        ;; which says they are required during building.  We
 303                        ;; have not yet had a need for cross-compiled perl
 304                        ;; modules, however, so we leave it out.
 305                        (convert-inputs '(configure build test)))
 306        ,@(maybe-inputs 'propagated-inputs
 307                        (convert-inputs '(runtime)))
 308        (home-page ,(cpan-home name))
 309        (synopsis ,(cpan-release-abstract release))
 310        (description fill-in-yourself!)
 311        (license ,(string->license (cpan-release-license release))))))
 312
 313 (define (cpan->guix-package module-name)
 314   "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
 315 `package' s-expression corresponding to that package, or #f on failure."
 316   (let ((release (cpan-fetch (module->name module-name))))
 317     (and=> release cpan-module->sexp)))
 318
 319 (define cpan-package?
 320   (let ((cpan-rx (make-regexp (string-append "("
 321                                              "mirror://cpan" "|"
 322                                              "https?://www.cpan.org" "|"
 323                                              "https?://cpan.metacpan.org"
 324                                              ")"))))
 325     (url-predicate (cut regexp-exec cpan-rx <>))))
 326
 327 (define (latest-release package)
 328   "Return an <upstream-source> for the latest release of PACKAGE."
 329   (match (cpan-fetch (package->upstream-name package))
 330     (#f #f)
 331     (release
 332      (let ((core-inputs
 333             (match (package-direct-inputs package)
 334               (((_ inputs _ ...) ...)
 335                (filter-map (match-lambda
 336                              ((and (? package?)
 337                                    (? cpan-package?)
 338                                    (= package->upstream-name
 339                                       (? core-module? name)))
 340                               name)
 341                              (else #f))
 342                            inputs)))))
 343        ;; Warn about inputs that are part of perl's core
 344        (unless (null? core-inputs)
 345          (for-each (lambda (module)
 346                      (warning (G_ "input '~a' of ~a is in Perl core~%")
 347                               module (package-name package)))
 348                    core-inputs)))
 349      (let ((version (cpan-release-version release))
 350            (url     (cpan-source-url release)))
 351        (upstream-source
 352         (package (package-name package))
 353         (version version)
 354         (urls (list url)))))))
 355
 356 (define %cpan-updater
 357   (upstream-updater
 358    (name 'cpan)
 359    (description "Updater for CPAN packages")
 360    (pred cpan-package?)
 361    (latest latest-release)))