You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

318 lines
12 KiB

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import cpan)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
#:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (json)
#:use-module (gcrypt hash)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix ui)
#:use-module ((guix download) #:select (download-to-store url-fetch))
#:use-module ((guix import utils) #:select (factorize-uri
flatten assoc-ref*))
#:use-module (guix import json)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (guix derivations)
#:export (cpan->guix-package
%cpan-updater))
;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of a CPAN
;;; module, using meta-data from metacpan.org.
;;;
;;; Code:
(define string->license
(match-lambda
;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
;; Some licenses are excluded based on their absense from (guix licenses).
("agpl_3" 'agpl3)
;; apache_1_1
("apache_2_0" 'asl2.0)
;; artistic_1
("artistic_2" 'artistic2.0)
("bsd" 'bsd-3)
("freebsd" 'bsd-2)
;; gfdl_1_2
("gfdl_1_3" 'fdl1.3+)
("gpl_1" 'gpl1)
("gpl_2" 'gpl2)
("gpl_3" 'gpl3)
("lgpl_2_1" 'lgpl2.1)
("lgpl_3_0" 'lgpl3)
("mit" 'x11)
;; mozilla_1_0
("mozilla_1_1" 'mpl1.1)
("openssl" 'openssl)
("perl_5" 'perl-license) ;GPL1+ and Artistic 1
("qpl_1_0" 'qpl)
;; ssleay
;; sun
("zlib" 'zlib)
((x) (string->license x))
((lst ...) `(list ,@(map string->license lst)))
(_ #f)))
(define (module->name module)
"Transform a 'module' name into a 'release' name"
(regexp-substitute/global #f "::" module 'pre "-" 'post))
(define (module->dist-name module)
"Return the base distribution module for a given module. E.g. the 'ok'
module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
return \"Test-Simple\""
(assoc-ref (json-fetch-alist (string-append
"https://fastapi.metacpan.org/v1/module/"
module
"?fields=distribution"))
"distribution"))
(define (package->upstream-name package)
"Return the CPAN name of PACKAGE."
(let* ((properties (package-properties package))
(upstream-name (and=> properties
(cut assoc-ref <> 'upstream-name))))
(or upstream-name
(match (package-source package)
((? origin? origin)
(match (origin-uri origin)
((or (? string? url) (url _ ...))
(match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
(#f #f)
(m (match:substring m 1))))
(_ #f)))
(_ #f)))))
(define (cpan-fetch name)
"Return an alist representation of the CPAN metadata for the perl module MODULE,
or #f on failure. MODULE should be e.g. \"Test::Script\""
;; This API always returns the latest release of the module.
(json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
(define (cpan-home name)
(string-append "https://metacpan.org/release/" name))
(define (cpan-source-url meta)
"Return the download URL for a module's source tarball."
(regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
(assoc-ref meta "download_url")
'pre "mirror://cpan" 'post))
(define (cpan-version meta)
"Return the version number from META."
(match (assoc-ref meta "version")
((? number? version)
;; version is sometimes not quoted in the module json, so it gets
;; imported into Guile as a number, so convert it to a string.
(number->string version))
(version
;; Sometimes we get a "v" prefix. Strip it.
(if (string-prefix? "v" version)
(string-drop version 1)
version))))
(define (perl-package)
"Return the 'perl' package. This is a lazy reference so that we don't
depend on (gnu packages perl)."
(module-ref (resolve-interface '(gnu packages perl)) 'perl))
(define %corelist
(delay
(let* ((perl (with-store store
(derivation->output-path
(package-derivation store (perl-package)))))
(core (string-append perl "/bin/corelist")))
(and (access? core X_OK)
core))))
(define core-module?
(let ((rx (make-regexp
(string-append "released with perl v?([0-9\\.]*)"
"(.*and removed from v?([0-9\\.]*))?"))))
(lambda (name)
(define perl-version
(package-version (perl-package)))
(define (version-between? lower version upper)
(and (version>=? version lower)
(or (not upper)
(version>? upper version))))
(and (force %corelist)
(parameterize ((current-error-port (%make-void-port "w")))
(let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
(let loop ()
(let ((line (read-line corelist)))
(if (eof-object? line)
(begin (close-pipe corelist) #f)
(or (and=> (regexp-exec rx line)
(lambda (m)
(let ((first (match:substring m 1))
(last (match:substring m 3)))
(version-between?
first perl-version last))))
(loop)))))))))))
(define (cpan-module->sexp meta)
"Return the `package' s-expression for a CPAN module from the metadata in
META."
(define name
(assoc-ref meta "distribution"))
(define (guix-name name)
(if (string-prefix? "perl-" name)
(string-downcase name)
(string-append "perl-" (string-downcase name))))
(define version (cpan-version meta))
(define source-url (cpan-source-url meta))
(define (convert-inputs phases)
;; Convert phase dependencies into a list of name/variable pairs.
(match (flatten
(map (lambda (ph)
(filter-map (lambda (t)
(assoc-ref* meta "metadata" "prereqs" ph t))
'("requires" "recommends" "suggests")))
phases))
(#f
'())
((inputs ...)
(sort
(delete-duplicates
;; Listed dependencies may include core modules. Filter those out.
(filter-map (match-lambda
(("perl" . _) ;implicit dependency
#f)
((module . _)
(and (not (core-module? module))
(let ((name (guix-name (module->dist-name module))))
(list name
(list 'unquote (string->symbol name)))))))
inputs))
(lambda args
(match args
(((a _ ...) (b _ ...))
(string<? a b))))))))
(define (maybe-inputs guix-name inputs)
(match inputs
(()
'())
((inputs ...)
(list (list guix-name
(list 'quasiquote inputs))))))
(let ((tarball (with-store store
(download-to-store store source-url))))
`(package
(name ,(guix-name name))
(version ,version)
(source (origin
(method url-fetch)
(uri (string-append ,@(factorize-uri source-url version)))
(sha256
(base32
,(bytevector->nix-base32-string (file-sha256 tarball))))))
(build-system perl-build-system)
,@(maybe-inputs 'native-inputs
;; "runtime" may also be needed here. See
;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
;; which says they are required during building. We
;; have not yet had a need for cross-compiled perl
;; modules, however, so we leave it out.
(convert-inputs '("configure" "build" "test")))
,@(maybe-inputs 'propagated-inputs
(convert-inputs '("runtime")))
(home-page ,(cpan-home name))
(synopsis ,(assoc-ref meta "abstract"))
(description fill-in-yourself!)
(license ,(string->license (assoc-ref meta "license"))))))
(define (cpan->guix-package module-name)
"Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
(let ((module-meta (cpan-fetch (module->name module-name))))
(and=> module-meta cpan-module->sexp)))
(define (cpan-package? package)
"Return #t if PACKAGE is a package from CPAN."
(define cpan-url?
(let ((cpan-rx (make-regexp (string-append "("
"mirror://cpan" "|"
"https?://www.cpan.org" "|"
"https?://cpan.metacpan.org"
")"))))
(lambda (url)
(regexp-exec cpan-rx url))))
(let ((source-url (and=> (package-source package) origin-uri))
(fetch-method (and=> (package-source package) origin-method)))
(and (eq? fetch-method url-fetch)
(match source-url
((? string?)
(cpan-url? source-url))
((source-url ...)
(any cpan-url? source-url))))))
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
(match (cpan-fetch (package->upstream-name package))
(#f #f)
(meta
(let ((core-inputs
(match (package-direct-inputs package)
(((_ inputs _ ...) ...)
(filter-map (match-lambda
((and (? package?)
(? cpan-package?)
(= package->upstream-name
(? core-module? name)))
name)
(else #f))
inputs)))))
;; Warn about inputs that are part of perl's core
(unless (null? core-inputs)
(for-each (lambda (module)
(warning (G_ "input '~a' of ~a is in Perl core~%")
module (package-name package)))
core-inputs)))
(let ((version (cpan-version meta))
(url (cpan-source-url meta)))
(upstream-source
(package (package-name package))
(version version)
(urls (list url)))))))
(define %cpan-updater
(upstream-updater
(name 'cpan)
(description "Updater for CPAN packages")
(pred cpan-package?)
(latest latest-release)))