kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

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

Browse Source 
* 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.
This commit is contained in:
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 © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -27,19 +28,39 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (json)
#:use-module (guix 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 utils) #:select (factorize-uri))
#:use-module (guix import json)
#:use-module (guix packages)
#:use-module (guix upstream)
#: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))
;;; Commentary:
@ -49,6 +70,45 @@
;;;
;;; 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
(match-lambda
;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
@ -111,32 +171,25 @@ return \"Test-Simple\""
(_ #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\""
"Return a <cpan-release> record for Perl module MODULE,
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.
(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)
(string-append "https://metacpan.org/release/" name))
(define (cpan-source-url meta)
"Return the download URL for a module's source tarball."
(define (metacpan-url->mirror-url url)
"Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
(regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
(assoc-ref meta "download_url")
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 cpan-source-url
(compose metacpan-url->mirror-url cpan-release-download-url))
(define (perl-package)
"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))))
(loop)))))))))))
(define (cpan-module->sexp meta)
"Return the `package' s-expression for a CPAN module from the metadata in
META."
(define (cpan-module->sexp release)
"Return the 'package' s-expression for a CPAN module from the release data
in RELEASE, a <cpan-release> record."
(define name
(assoc-ref meta "distribution"))
(cpan-release-distribution release))
(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 version (cpan-release-version release))
(define source-url (cpan-source-url release))
(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
'())
(match (filter-map (lambda (dependency)
(and (memq (cpan-dependency-phase dependency)
phases)
(cpan-dependency-module dependency)))
(cpan-release-dependencies release))
((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)))))))
("perl" #f) ;implicit dependency
((? core-module?) #f)
(module
(let ((name (guix-name (module->dist-name module))))
(list name
(list 'unquote (string->symbol name))))))
inputs))
(lambda args
(match args
@ -247,19 +296,19 @@ META."
;; 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")))
(convert-inputs '(configure build test)))
,@(maybe-inputs 'propagated-inputs
(convert-inputs '("runtime")))
(convert-inputs '(runtime)))
(home-page ,(cpan-home name))
(synopsis ,(assoc-ref meta "abstract"))
(synopsis ,(cpan-release-abstract release))
(description fill-in-yourself!)
(license ,(string->license (assoc-ref meta "license"))))))
(license ,(string->license (cpan-release-license release))))))
(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)))
(let ((release (cpan-fetch (module->name module-name))))
(and=> release cpan-module->sexp)))
(define (cpan-package? package)
"Return #t if PACKAGE is a package from CPAN."
@ -285,7 +334,7 @@ META."
"Return an <upstream-source> for the latest release of PACKAGE."
(match (cpan-fetch (package->upstream-name package))
(#f #f)
(meta
(release
(let ((core-inputs
(match (package-direct-inputs package)
(((_ inputs _ ...) ...)
@ -303,8 +352,8 @@ META."
(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)))
(let ((version (cpan-release-version release))
(url (cpan-source-url release)))
(upstream-source
(package (package-name package))
(version version)

33
tests/cpan.scm
View File

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