Package: guix-patches;
Reported by: Maxime Devos <maximedevos <at> telenet.be>
Date: Mon, 2 Aug 2021 15:48:02 UTC
Severity: normal
Tags: patch
Done: Leo Prikler <leo.prikler <at> student.tugraz.at>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Maxime Devos <maximedevos <at> telenet.be> To: 49828 <at> debbugs.gnu.org Cc: Maxime Devos <maximedevos <at> telenet.be> Subject: [bug#49828] [PATCH 06/20] guix: Add ContentDB importer. Date: Mon, 2 Aug 2021 17:50:05 +0200
* guix/import/contentdb.scm: New file.
* guix/scripts/import/contentdb.scm: New file.
* tests/contentdb.scm: New file.
* Makefile.am (MODULES, SCM_TESTS): Register them.
* po/guix/POTFILES.in: Likewise.
* doc/guix.texi (Invoking guix import): Document it.
---
Makefile.am | 3 +
doc/guix.texi | 25 +++
guix/import/contentdb.scm | 310 ++++++++++++++++++++++++++++++
guix/scripts/import.scm | 3 +-
guix/scripts/import/contentdb.scm | 106 ++++++++++
po/guix/POTFILES.in | 1 +
tests/contentdb.scm | 227 ++++++++++++++++++++++
7 files changed, 674 insertions(+), 1 deletion(-)
create mode 100644 guix/import/contentdb.scm
create mode 100644 guix/scripts/import/contentdb.scm
create mode 100644 tests/contentdb.scm
diff --git a/Makefile.am b/Makefile.am
index f6fae09579..b9265c154d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -261,6 +261,7 @@ MODULES = \
guix/import/json.scm \
guix/import/kde.scm \
guix/import/launchpad.scm \
+ guix/import/contentdb.scm \
guix/import/opam.scm \
guix/import/print.scm \
guix/import/pypi.scm \
@@ -303,6 +304,7 @@ MODULES = \
guix/scripts/import/go.scm \
guix/scripts/import/hackage.scm \
guix/scripts/import/json.scm \
+ guix/scripts/import/contentdb.scm \
guix/scripts/import/opam.scm \
guix/scripts/import/pypi.scm \
guix/scripts/import/stackage.scm \
@@ -445,6 +447,7 @@ SCM_TESTS = \
tests/channels.scm \
tests/combinators.scm \
tests/containers.scm \
+ tests/contentdb.scm \
tests/cpan.scm \
tests/cpio.scm \
tests/cran.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 43c248234d..d06c9b73c5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11313,6 +11313,31 @@ and generate package expressions for all those packages that are not yet
in Guix.
@end table
+@item contentdb
+@cindex ContentDB
+Import metadata from @uref{https://content.minetest.net, ContentDB}.
+Information is taken from the JSON-formatted metadata provided through
+@uref{https://content.minetest.net/help/api/, ContentDB's API} and
+includes most relevant information, including dependencies. There are
+some caveats, however. The license information on ContentDB does not
+distinguish between GPLvN-only and GPLvN-or-later. The commit id is
+sometimes missing. The descriptions are in the Markdown format, but
+Guix uses Texinfo instead. Texture packs and subgames are unsupported.
+
+The command below imports metadata for the Mesecons mod by Jeija:
+
+@example
+guix import contentdb Jeija mesecons
+@end example
+
+@table @code
+@item --recursive
+@itemx -r
+Traverse the dependency graph of the given upstream package recursively
+and generate package expressions for all those packages that are not yet
+in Guix.
+@end table
+
@item cpan
@cindex CPAN
Import metadata from @uref{https://www.metacpan.org/, MetaCPAN}.
diff --git a/guix/import/contentdb.scm b/guix/import/contentdb.scm
new file mode 100644
index 0000000000..1a36a09c92
--- /dev/null
+++ b/guix/import/contentdb.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet;be>
+;;;
+;;; 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 contentdb)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix serialization)
+ #:use-module (guix import utils)
+ #:use-module (guix import json)
+ #:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256))
+ #:use-module (json)
+ #:use-module (guix base32)
+ #:use-module (guix git)
+ #:use-module (guix store)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:export (%contentdb-api
+ contentdb->guix-package
+ contentdb-recursive-import))
+
+;; The ContentDB API is documented at
+;; <https://content.minetest.net>.
+
+(define %contentdb-api
+ (make-parameter "https://content.minetest.net/api/"))
+
+(define (string-or-false x)
+ (and (string? x) x))
+
+(define (natural-or-false x)
+ (and (exact-integer? x) (>= x 0) x))
+
+;; Descriptions on ContentDB use carriage returns, but Guix doesn't.
+(define (delete-cr text)
+ (string-delete #\cr text))
+
+;; Minetest package.
+;;
+;; API endpoint: /packages/AUTHOR/NAME/
+(define-json-mapping <package> make-package package?
+ json->package
+ (author package-author) ; string
+ (creation-date package-creation-date ; string
+ "created_at")
+ (downloads package-downloads) ; integer
+ (forums package-forums "forums" natural-or-false) ; natural | #f
+ (issue-tracker package-issue-tracker "issue_tracker") ; string
+ (license package-license) ; string
+ (long-description package-long-description "long_description") ; string
+ (maintainers package-maintainers ; list of strings
+ "maintainers" vector->list)
+ (media-license package-media-license "media_license") ; string
+ (name package-name) ; string
+ (provides package-provides ; list of strings
+ "provides" vector->list)
+ (release package-release) ; integer
+ (repository package-repository "repo" string-or-false) ; string | #f
+ (score package-score) ; flonum
+ (screenshots package-screenshots "screenshots" vector->list) ; list of strings
+ (short-description package-short-description "short_description") ; string
+ (state package-state) ; string
+ (tags package-tags "tags" vector->list) ; list of strings
+ (thumbnail package-thumbnail) ; string
+ (title package-title) ; string
+ (type package-type) ; string
+ (url package-url) ; string
+ (website package-website "website" string-or-false)) ; string | #f
+
+(define-json-mapping <release> make-release release?
+ json->release
+ (commit release-commit "commit" string-or-false) ; string | #f
+ (downloads release-downloads) ; integer
+ (id release-id) ; integer
+ (max-minetest-version release-max-minetest-version) ; string | #f
+ (min-minetest-version release-min-minetest-version) ; string | #f
+ (release-date release-data) ; string
+ (title release-title) ; string
+ (url release-url)) ; string
+
+(define-json-mapping <dependency> make-dependency dependency?
+ json->dependency
+ (optional? dependency-optional? "is_optional") ; #t | #f
+ (name dependency-name) ; string
+ (packages dependency-packages "packages" vector->list)) ; list of strings
+
+(define (contentdb-fetch author name)
+ "Return a <package> record for package NAME by AUTHOR, or #f on failure."
+ (and=> (json-fetch
+ (string-append (%contentdb-api) "packages/" author "/" name "/"))
+ json->package))
+
+(define (contentdb-fetch-releases author name)
+ "Return a list of <release> records for package NAME by AUTHOR, or #f
+on failure."
+ (and=> (json-fetch (string-append (%contentdb-api) "packages/" author "/" name
+ "/releases/"))
+ (lambda (json)
+ (map json->release (vector->list json)))))
+
+(define (latest-release author name)
+ "Return the latest source release for package NAME by AUTHOR,
+or #f if this package does not exist."
+ (and=> (contentdb-fetch-releases author name)
+ car))
+
+(define (contentdb-fetch-dependencies author name)
+ "Return an alist of lists of <dependency> records for package NAME by AUTHOR
+and possibly some other packages as well, or #f on failure."
+ (define url (string-append (%contentdb-api) "packages/" author "/" name
+ "/dependencies/"))
+ (and=> (json-fetch url)
+ (lambda (json)
+ (map (match-lambda
+ ((key . value)
+ (cons key (map json->dependency (vector->list value)))))
+ json))))
+
+(define (contentdb->package-name name)
+ "Given the NAME of a package on ContentDB, return a Guix-compliant name for the
+package."
+ ;; The author is not included, as the names of popular mods
+ ;; tend to be unique.
+ (string-append "minetest-" (snake-case name)))
+
+;; XXX copied from (guix import elpa)
+(define* (download-git-repository url ref)
+ "Fetch the given REF from the Git repository at URL."
+ (with-store store
+ (latest-repository-commit store url #:ref ref)))
+
+;; XXX adapted from (guix scripts hash)
+(define (file-hash file select? recursive?)
+ ;; Compute the hash of FILE.
+ (if recursive?
+ (let-values (((port get-hash) (open-sha256-port)))
+ (write-file file port #:select? select?)
+ (force-output port)
+ (get-hash))
+ (call-with-input-file file port-sha256)))
+;; XXX likewise.
+(define (vcs-file? file stat)
+ (case (stat:type stat)
+ ((directory)
+ (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+ ((regular)
+ ;; Git sub-modules have a '.git' file that is a regular text file.
+ (string=? (basename file) ".git"))
+ (else
+ #f)))
+
+(define (make-minetest-sexp name version repository commit
+ inputs home-page synopsis
+ description media-license license)
+ "Return a S-expression for the minetest package with the given NAME,
+VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
+MEDIA-LICENSE and LICENSE."
+ `(package
+ (name ,(contentdb->package-name name))
+ (version ,version)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,repository)
+ (commit ,commit)))
+ (sha256
+ (base32
+ ;; The commit id is not always available.
+ ,(and commit
+ (bytevector->nix-base32-string
+ (file-hash
+ (download-git-repository repository `(commit . ,commit))
+ (negate vcs-file?) #t)))))
+ (file-name (git-file-name name version))))
+ (build-system minetest-mod-build-system)
+ ,@(maybe-propagated-inputs
+ (map (compose contentdb->package-name cdr) inputs))
+ (home-page ,home-page)
+ (synopsis ,(delete-cr synopsis))
+ (description ,(delete-cr description))
+ (license ,(if (eq? media-license license)
+ (license->symbol license)
+ `(list ,(license->symbol media-license)
+ ,(license->symbol license))))))
+
+(define (package-home-page package)
+ "Guess the home page of the ContentDB package PACKAGE.
+
+In order of preference, try the 'website', the forum topic on the
+official Minetest forum and the Git repository (if any)."
+ (define (topic->url-sexp topic)
+ ;; 'minetest-topic' is a procedure defined in (gnu packages minetest)
+ `(minetest-topic ,topic))
+ (or (package-website package)
+ (and=> (package-forums package) topic->url-sexp)
+ (package-repository package)))
+
+(define (important-dependencies dependencies author name)
+ (define dependency-list
+ (assoc-ref dependencies (string-append author "/" name)))
+ (filter-map
+ (lambda (dependency)
+ (and (not (dependency-optional? dependency))
+ ;; "default" must be provided by the 'subgame' in use
+ ;; and does not refer to a specific minetest mod.
+ ;; "doors", "bucket" ... are provided by the default minetest
+ ;; subgame.
+ (not (member (dependency-name dependency)
+ '("default" "doors" "beds" "bucket" "doors" "farming"
+ "flowers" "stairs" "xpanes")))
+ ;; Dependencies often have only one implementation.
+ (let* ((/name (string-append "/" (dependency-name dependency)))
+ (likewise-named-implementations
+ (filter (cut string-suffix? /name <>)
+ (dependency-packages dependency)))
+ (implementation
+ (and (not (null? likewise-named-implementations))
+ (first likewise-named-implementations))))
+ (and implementation
+ (apply cons (string-split implementation #\/))))))
+ dependency-list))
+
+(define* (%contentdb->guix-package author name)
+ "Fetch the metadata for NAME by AUTHOR from https://content.minetest.net, and
+return the 'package' S-expression corresponding to that package, or #f on failure.
+On success, also return the upstream dependencies as a list of
+(AUTHOR . NAME) pairs."
+ (and-let* ((package (contentdb-fetch author name))
+ (dependencies (contentdb-fetch-dependencies author name))
+ (release (latest-release author name)))
+ (let ((important-upstream-dependencies
+ (important-dependencies dependencies author name)))
+ (values (make-minetest-sexp name
+ (release-title release) ; version
+ (package-repository package)
+ (release-commit release)
+ important-upstream-dependencies
+ (package-home-page package)
+ (package-short-description package)
+ (package-long-description package)
+ (string->license
+ (package-media-license package))
+ (string->license
+ (package-license package)))
+ important-upstream-dependencies))))
+
+(define contentdb->guix-package
+ (memoize %contentdb->guix-package))
+
+(define (contentdb-recursive-import author name)
+ ;; recursive-import expects upstream package names to be strings,
+ ;; so do some conversions.
+ (define (split-author/name author/name)
+ (string-split author/name #\/))
+ (define (author+name->author/name author+name)
+ (string-append (car author+name) "/" (cdr author+name)))
+ (define* (contentdb->guix-package* author/name #:key repo version)
+ (receive (package . maybe-dependencies)
+ (apply contentdb->guix-package (split-author/name author/name))
+ (and package
+ (receive (dependencies)
+ (apply values maybe-dependencies)
+ (values package
+ (map author+name->author/name dependencies))))))
+ (recursive-import (author+name->author/name (cons author name))
+ #:repo->guix-package contentdb->guix-package*
+ #:guix-name
+ (lambda (author/name)
+ (contentdb->package-name
+ (second (split-author/name author/name))))))
+
+;; A list of license names is available at
+;; <https://content.minetest.net/api/licenses/>.
+(define (string->license str)
+ "Convert the string STR into a license object."
+ (match str
+ ("GPLv3" license:gpl3)
+ ("GPLv2" license:gpl2)
+ ("ISC" license:isc)
+ ;; "MIT" means the Expat license on ContentDB,
+ ;; see <https://github.com/minetest/contentdb/issues/326#issuecomment-890143784>.
+ ("MIT" license:expat)
+ ("CC BY-SA 3.0" license:cc-by-sa3.0)
+ ("CC BY-SA 4.0" license:cc-by-sa4.0)
+ ("LGPLv2.1" license:lgpl2.1)
+ ("LGPLv3" license:lgpl3)
+ ("MPL 2.0" license:mpl2.0)
+ ("ZLib" license:zlib)
+ ("Unlicense" license:unlicense)
+ (_ #f)))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index f53d1ac1f4..015677e719 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -77,7 +77,8 @@ rather than \\n."
;;;
(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa"
- "gem" "go" "cran" "crate" "texlive" "json" "opam"))
+ "gem" "go" "cran" "crate" "texlive" "json" "opam"
+ "contentdb"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/contentdb.scm b/guix/scripts/import/contentdb.scm
new file mode 100644
index 0000000000..4170fff950
--- /dev/null
+++ b/guix/scripts/import/contentdb.scm
@@ -0,0 +1,106 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 David Thompson <davet <at> gnu.org>
+;;; Copyright © 2018 Ricardo Wurmus <rekado <at> elephly.net>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet.be>
+;;;
+;;; 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 scripts import contentdb)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import contentdb)
+ #:use-module (guix import utils)
+ #:use-module (guix scripts import)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:export (guix-import-contentdb))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (G_ "Usage: guix import contentdb AUTHOR NAME
+Import and convert the Minetest mod NAME by AUTHOR from ContentDB.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -r, --recursive import packages recursively"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix import contentdb")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-contentdb . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((author name)
+ (with-error-handling
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import
+ (filter-map package->definition
+ (contentdb-recursive-import author name))
+ ;; Single import
+ (let ((sexp (contentdb->guix-package author name)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a' by '~a'~%")
+ name author))
+ sexp))))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index a3bced1a8f..f25a7b4802 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -60,6 +60,7 @@ guix/scripts/git.scm
guix/scripts/git/authenticate.scm
guix/scripts/hash.scm
guix/scripts/import.scm
+guix/scripts/import/contentdb.scm
guix/scripts/import/cran.scm
guix/scripts/import/elpa.scm
guix/scripts/pull.scm
diff --git a/tests/contentdb.scm b/tests/contentdb.scm
new file mode 100644
index 0000000000..1293ac40cf
--- /dev/null
+++ b/tests/contentdb.scm
@@ -0,0 +1,227 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet.be>
+;;;
+;;; 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 (test-contentdb)
+ #:use-module (guix memoization)
+ #:use-module (guix import contentdb)
+ #:use-module (guix import utils)
+ #:use-module (guix tests)
+ #:use-module (json)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64))
+
+
+;; Some procedures for populating a ‘fake’ ContentDB server.
+
+(define* (make-package-sexp #:key
+ (guix-name "minetest-foo")
+ (home-page "https://example.org/foo")
+ (repo "https://example.org/foo.git")
+ (synopsis "synopsis")
+ (guix-description "description")
+ (guix-license '(list license:cc-by-sa4.0 license:lgpl3))
+ (inputs '())
+ #:allow-other-keys)
+ `(package
+ (name ,guix-name)
+ ;; This is not a proper version number but ContentDB does not include
+ ;; version numbers.
+ (version "2021-07-25")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,(and (not (eq? repo 'null)) repo))
+ (commit #f)))
+ (sha256
+ (base32 #f))
+ (file-name (git-file-name name version))))
+ (build-system minetest-mod-build-system)
+ ,@(maybe-propagated-inputs inputs)
+ (home-page ,home-page)
+ (synopsis ,synopsis)
+ (description ,guix-description)
+ (license ,guix-license)))
+
+(define* (make-package-json #:key
+ (author "Author")
+ (name "foo")
+ (media-license "CC BY-SA 4.0")
+ (license "LGPLv3")
+ (short-description "synopsis")
+ (long-description "description")
+ (repo "https://example.org/foo.git")
+ (website "https://example.org/foo")
+ (forums 321)
+ #:allow-other-keys)
+ `(("author" . ,author)
+ ("content_warnings" . #())
+ ("created_at" . "2018-05-23T19:58:07.422108")
+ ("downloads" . 123)
+ ("forums" . ,forums)
+ ("issue_tracker" . "https://example.org/foo/issues")
+ ("license" . ,license)
+ ("long_description" . ,long-description)
+ ("maintainers" . #("maintainer"))
+ ("media_license" . ,media-license)
+ ("name" . ,name)
+ ("provides" . #("stuff"))
+ ("release" . 456)
+ ("repo" . ,repo)
+ ("score" . ,987.654)
+ ("screenshots" . #())
+ ("short_description" . ,short-description)
+ ("state" . "APPROVED")
+ ("tags" . #("some" "tags"))
+ ("thumbnail" . null)
+ ("title" . "The name")
+ ("type" . "mod")
+ ("url" . ,(string-append "https://content.minetest.net/packages/"
+ author "/" name "/download/"))
+ ("website" . ,website)))
+
+(define* (make-releases-json #:key (commit #f) (title "") #:allow-other-keys)
+ `#((("commit" . ,commit)
+ ("downloads" . 469)
+ ("id" . 8614)
+ ("max_minetest_version" . null)
+ ("min_minetest_version" . null)
+ ("release_date" . "2021-07-25T01:10:23.207584")
+ ("title" . "2021-07-25"))))
+
+(define* (make-dependencies-json #:key (author "Author")
+ (name "foo")
+ (requirements '(("default" #f ())))
+ #:allow-other-keys)
+ `((,(string-append author "/" name)
+ . ,(list->vector
+ (map (match-lambda
+ ((symbolic-name optional? implementations)
+ `(("is_optional" . ,optional?)
+ ("name" . ,symbolic-name)
+ ("packages" . ,(list->vector implementations)))))
+ requirements)))
+ ("something/else" . #())))
+
+(define (call-with-packages thunk . argument-lists)
+ (mock ((guix http-client) http-fetch
+ (lambda* (url #:key headers)
+ (unless (string-prefix? "mock://api/packages/" url)
+ (error "the URL ~a should not be used" url))
+ (define resource
+ (substring url (string-length "mock://api/packages/")))
+ (define components (string-split resource #\/))
+ (unless (>= (length components) 2)
+ (error "the URL ~a should have an author and name component" url))
+ (define requested-author (list-ref components 0))
+ (define requested-name (list-ref components 1))
+ (define rest (cddr components))
+ (define relevant-argument-list
+ (any (lambda (argument-list)
+ (apply (lambda* (#:key (author "Author") (name "foo")
+ #:allow-other-keys)
+ (and (equal? requested-author author)
+ (equal? requested-name name)
+ argument-list))
+ argument-list))
+ argument-lists))
+ (when (not relevant-argument-list)
+ (error "the package ~a/~a should be irrelevant, but ~a is fetched"
+ requested-author requested-name url))
+ (define (scm->json-port scm)
+ (open-input-string (scm->json-string scm)))
+ (scm->json-port
+ (apply (match rest
+ (("") make-package-json)
+ (("dependencies" "") make-dependencies-json)
+ (("releases" "") make-releases-json)
+ (_ (error "TODO ~a" rest)))
+ relevant-argument-list))))
+ (parameterize ((%contentdb-api "mock://api/"))
+ (thunk))))
+
+(define* (contentdb->guix-package* #:key (author "Author") (name "foo")
+ #:allow-other-keys)
+ (contentdb->guix-package author name))
+
+(define (imported-package-sexp . extra-arguments)
+ (call-with-packages
+ (lambda ()
+ ;; Don't reuse results from previous tests.
+ (invalidate-memoization! contentdb->guix-package)
+ (apply contentdb->guix-package* extra-arguments))
+ extra-arguments))
+
+(define-syntax-rule (test-package test-case . extra-arguments)
+ (test-equal test-case
+ (make-package-sexp . extra-arguments)
+ (imported-package-sexp . extra-arguments)))
+
+(test-begin "contentdb")
+
+
+;; Package names
+(test-package "contentdb->guix-package")
+(test-package "contentdb->guix-package, _ → - in package name"
+ #:name "foo_bar"
+ #:guix-name "minetest-foo-bar")
+
+
+;; Determining the home page
+(test-package "contentdb->guix-package, website is used as home page"
+ #:home-page "web://site"
+ #:website "web://site")
+(test-package "contentdb->guix-package, if absent, the forum is used"
+ #:home-page '(minetest-topic 628)
+ #:forums 628
+ #:website 'null)
+(test-package "contentdb->guix-package, if absent, the git repo is used"
+ #:home-page "https://github.com/minetest-mods/mesecons"
+ #:forums 'null
+ #:website 'null
+ #:repo "https://github.com/minetest-mods/mesecons")
+(test-package "contentdb->guix-package, all home page information absent"
+ #:home-page #f
+ #:forums 'null
+ #:website 'null
+ #:repo 'null)
+
+
+
+;; Dependencies
+(test-package "contentdb->guix-package, dependency"
+ #:requirements '(("mesecons" #f
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '("minetest-mesecons"))
+
+(test-package "contentdb->guix-package, optional dependency"
+ #:requirements '(("mesecons" #t
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '())
+
+
+;; License
+(test-package "contentdb->guix-package, identical licenses"
+ #:guix-license 'license:lgpl3
+ #:license "LGPLv3"
+ #:media-license "LGPLv3")
+
+(test-end "contentdb")
--
2.32.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.