;;; 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)))