me
/
guix
Archived
1
0
Fork 0
Code

import: cpan: Rewrite to use 'define-json-mapping'. 

* guix/import/cpan.scm (<cpan-dependency>, <cpan-release>): New
JSON-mapped record types.
(metacpan-url->mirror-url): New procedure.
(cpan-source-url): Rewrite in terms of it.
(cpan-version): Remove.
(cpan-module->sexp): Rewrite to take a <cpan-release> instead of an
alist, and rename 'meta' to 'release'.
[convert-inputs]: Rewrite to use 'cpan-release-dependencies'.
Update calls to 'convert-inputs' to pass a list of symbols.
Replace 'assoc-ref' calls with the appropriate field accessors.
(cpan->guix-package): Rename 'module-meta' to 'release'.
(latest-release): Likewise, and use the appropriate accessors.
* tests/cpan.scm (test-json): Remove "prereqs" record; add "dependency"
list.
("source-url-http", "source-url-https"): Remove.
("metacpan-url->mirror-url, http")
("metacpan-url->mirror-url, https"): New tests.
master
Ludovic Courtès 2020-01-15 18:05:26 +01:00
parent ea6d962b93
commit 69f132554c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 116 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

151
guix/import/cpan.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -27,19 +28,39 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (json) #:use-module (json)
#:use-module (guix json)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix download) #:select (download-to-store url-fetch))
#:use-module ((guix import utils) #:select (factorize-uri #:use-module ((guix import utils) #:select (factorize-uri))
flatten assoc-ref*))
#:use-module (guix import json) #:use-module (guix import json)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix derivations) #:use-module (guix derivations)
#:export (cpan->guix-package #:export (cpan-dependency?
cpan-dependency-relationship
cpan-dependency-phase
cpan-dependency-module
cpan-dependency-version
cpan-release?
cpan-release-license
cpan-release-author
cpan-release-version
cpan-release-modle
cpan-release-distribution
cpan-release-download-url
cpan-release-abstract
cpan-release-home-page
cpan-release-dependencies
json->cpan-release
cpan-fetch
cpan->guix-package
metacpan-url->mirror-url
%cpan-updater)) %cpan-updater))
;;; Commentary: ;;; Commentary:
@ -49,6 +70,45 @@
;;; ;;;
;;; Code: ;;; Code:
;; Dependency of a "release".
(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency?
json->cpan-dependency
(relationship cpan-dependency-relationship "relationship"
string->symbol) ;requires | suggests
(phase cpan-dependency-phase "phase"
string->symbol) ;develop | configure | test | runtime
(module cpan-dependency-module) ;string
(version cpan-dependency-version)) ;string
;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>.
(define-json-mapping <cpan-release> make-cpan-release cpan-release?
json->cpan-release
(license cpan-release-license)
(author cpan-release-author)
(version cpan-release-version "version"
(match-lambda
((? 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 (example: "X11-Protocol-Other").
(number->string version))
((? string? version)
;; Sometimes we get a "v" prefix. Strip it.
(if (string-prefix? "v" version)
(string-drop version 1)
version))))
(module cpan-release-module "main_module") ;e.g., "Test::Script"
(distribution cpan-release-distribution) ;e.g., "Test-Script"
(download-url cpan-release-download-url "download_url")
(abstract cpan-release-abstract "abstract")
(home-page cpan-release-home-page "resources"
(match-lambda
(#f #f)
((lst ...) (assoc-ref lst "homepage"))))
(dependencies cpan-release-dependencies "dependency"
(lambda (vector)
(map json->cpan-dependency (vector->list vector)))))
(define string->license (define string->license
(match-lambda (match-lambda
;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec. ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
@ -111,32 +171,25 @@ return \"Test-Simple\""
(_ #f))))) (_ #f)))))
(define (cpan-fetch name) (define (cpan-fetch name)
"Return an alist representation of the CPAN metadata for the perl module MODULE, "Return a <cpan-release> record for Perl module MODULE,
or #f on failure. MODULE should be e.g. \"Test::Script\"" or #f on failure. MODULE should be the distribution name, such as
\"Test-Script\" for the \"Test::Script\" module."
;; This API always returns the latest release of the module. ;; This API always returns the latest release of the module.
(json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name))) (json->cpan-release
(json-fetch (string-append "https://fastapi.metacpan.org/v1/release/"
name))))
(define (cpan-home name) (define (cpan-home name)
(string-append "https://metacpan.org/release/" name)) (string-append "https://metacpan.org/release/" name))
(define (cpan-source-url meta) (define (metacpan-url->mirror-url url)
"Return the download URL for a module's source tarball." "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
(regexp-substitute/global #f "http[s]?://cpan.metacpan.org" (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
(assoc-ref meta "download_url") url
'pre "mirror://cpan" 'post)) 'pre "mirror://cpan" 'post))
(define (cpan-version meta) (define cpan-source-url
"Return the version number from META." (compose metacpan-url->mirror-url cpan-release-download-url))
(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) (define (perl-package)
"Return the 'perl' package. This is a lazy reference so that we don't "Return the 'perl' package. This is a lazy reference so that we don't
@ -179,42 +232,38 @@ depend on (gnu packages perl)."
first perl-version last)))) first perl-version last))))
(loop))))))))))) (loop)))))))))))
(define (cpan-module->sexp meta) (define (cpan-module->sexp release)
"Return the `package' s-expression for a CPAN module from the metadata in "Return the 'package' s-expression for a CPAN module from the release data
META." in RELEASE, a <cpan-release> record."
(define name (define name
(assoc-ref meta "distribution")) (cpan-release-distribution release))
(define (guix-name name) (define (guix-name name)
(if (string-prefix? "perl-" name) (if (string-prefix? "perl-" name)
(string-downcase name) (string-downcase name)
(string-append "perl-" (string-downcase name)))) (string-append "perl-" (string-downcase name))))
(define version (cpan-version meta)) (define version (cpan-release-version release))
(define source-url (cpan-source-url meta)) (define source-url (cpan-source-url release))
(define (convert-inputs phases) (define (convert-inputs phases)
;; Convert phase dependencies into a list of name/variable pairs. ;; Convert phase dependencies into a list of name/variable pairs.
(match (flatten (match (filter-map (lambda (dependency)
(map (lambda (ph) (and (memq (cpan-dependency-phase dependency)
(filter-map (lambda (t) phases)
(assoc-ref* meta "metadata" "prereqs" ph t)) (cpan-dependency-module dependency)))
'("requires" "recommends" "suggests"))) (cpan-release-dependencies release))
phases))
(#f
'())
((inputs ...) ((inputs ...)
(sort (sort
(delete-duplicates (delete-duplicates
;; Listed dependencies may include core modules. Filter those out. ;; Listed dependencies may include core modules. Filter those out.
(filter-map (match-lambda (filter-map (match-lambda
(("perl" . _) ;implicit dependency ("perl" #f) ;implicit dependency
#f) ((? core-module?) #f)
((module . _) (module
(and (not (core-module? module)) (let ((name (guix-name (module->dist-name module))))
(let ((name (guix-name (module->dist-name module)))) (list name
(list name (list 'unquote (string->symbol name))))))
(list 'unquote (string->symbol name)))))))
inputs)) inputs))
(lambda args (lambda args
(match args (match args
@ -247,19 +296,19 @@ META."
;; which says they are required during building. We ;; which says they are required during building. We
;; have not yet had a need for cross-compiled perl ;; have not yet had a need for cross-compiled perl
;; modules, however, so we leave it out. ;; modules, however, so we leave it out.
(convert-inputs '("configure" "build" "test"))) (convert-inputs '(configure build test)))
,@(maybe-inputs 'propagated-inputs ,@(maybe-inputs 'propagated-inputs
(convert-inputs '("runtime"))) (convert-inputs '(runtime)))
(home-page ,(cpan-home name)) (home-page ,(cpan-home name))
(synopsis ,(assoc-ref meta "abstract")) (synopsis ,(cpan-release-abstract release))
(description fill-in-yourself!) (description fill-in-yourself!)
(license ,(string->license (assoc-ref meta "license")))))) (license ,(string->license (cpan-release-license release))))))
(define (cpan->guix-package module-name) (define (cpan->guix-package module-name)
"Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
`package' s-expression corresponding to that package, or #f on failure." `package' s-expression corresponding to that package, or #f on failure."
(let ((module-meta (cpan-fetch (module->name module-name)))) (let ((release (cpan-fetch (module->name module-name))))
(and=> module-meta cpan-module->sexp))) (and=> release cpan-module->sexp)))
(define (cpan-package? package) (define (cpan-package? package)
"Return #t if PACKAGE is a package from CPAN." "Return #t if PACKAGE is a package from CPAN."
@ -285,7 +334,7 @@ META."
"Return an <upstream-source> for the latest release of PACKAGE." "Return an <upstream-source> for the latest release of PACKAGE."
(match (cpan-fetch (package->upstream-name package)) (match (cpan-fetch (package->upstream-name package))
(#f #f) (#f #f)
(meta (release
(let ((core-inputs (let ((core-inputs
(match (package-direct-inputs package) (match (package-direct-inputs package)
(((_ inputs _ ...) ...) (((_ inputs _ ...) ...)
@ -303,8 +352,8 @@ META."
(warning (G_ "input '~a' of ~a is in Perl core~%") (warning (G_ "input '~a' of ~a is in Perl core~%")
module (package-name package))) module (package-name package)))
core-inputs))) core-inputs)))
(let ((version (cpan-version meta)) (let ((version (cpan-release-version release))
(url (cpan-source-url meta))) (url (cpan-source-url release)))
(upstream-source (upstream-source
(package (package-name package)) (package (package-name package))
(version version) (version version)

33
tests/cpan.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -32,13 +33,6 @@
(define test-json (define test-json
"{ "{
\"metadata\" : { \"metadata\" : {
\"prereqs\" : {
\"runtime\" : {
\"requires\" : {
\"Test::Script\" : \"1.05\",
}
}
}
\"name\" : \"Foo-Bar\", \"name\" : \"Foo-Bar\",
\"version\" : \"0.1\" \"version\" : \"0.1\"
} }
@ -47,6 +41,13 @@
\"license\" : [ \"license\" : [
\"perl_5\" \"perl_5\"
], ],
\"dependency\": [
{ \"relationship\": \"requires\",
\"phase\": \"runtime\",
\"version\": \"1.05\",
\"module\": \"Test::Script\"
}
],
\"abstract\" : \"Fizzle Fuzz\", \"abstract\" : \"Fizzle Fuzz\",
\"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\", \"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\",
\"author\" : \"Guix\", \"author\" : \"Guix\",
@ -107,16 +108,14 @@
(x (x
(pk 'fail x #f)))))) (pk 'fail x #f))))))
(test-equal "source-url-http" (test-equal "metacpan-url->mirror-url, http"
((@@ (guix import cpan) cpan-source-url) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
`(("download_url" . (metacpan-url->mirror-url
"http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))
"mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
(test-equal "source-url-https" (test-equal "metacpan-url->mirror-url, https"
((@@ (guix import cpan) cpan-source-url) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
`(("download_url" . (metacpan-url->mirror-url
"https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))
"mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
(test-end "cpan") (test-end "cpan")