From 39d869370e7a286fb30a06512c08fd3399d92d4f Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 31 Jul 2021 14:44:11 +0200
Subject: [PATCH] guix: Add ContentDB importer.
* 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 | 32 +++
guix/import/minetest.scm | 456 +++++++++++++++++++++++++++++++
guix/scripts/import.scm | 3 +-
guix/scripts/import/minetest.scm | 117 ++++++++
po/guix/POTFILES.in | 1 +
tests/minetest.scm | 355 ++++++++++++++++++++++++
7 files changed, 966 insertions(+), 1 deletion(-)
create mode 100644 guix/import/minetest.scm
create mode 100644 guix/scripts/import/minetest.scm
create mode 100644 tests/minetest.scm
@@ -262,6 +262,7 @@ MODULES = \
guix/import/json.scm \
guix/import/kde.scm \
guix/import/launchpad.scm \
+ guix/import/minetest.scm \
guix/import/opam.scm \
guix/import/print.scm \
guix/import/pypi.scm \
@@ -304,6 +305,7 @@ MODULES = \
guix/scripts/import/go.scm \
guix/scripts/import/hackage.scm \
guix/scripts/import/json.scm \
+ guix/scripts/import/minetest.scm \
guix/scripts/import/opam.scm \
guix/scripts/import/pypi.scm \
guix/scripts/import/stackage.scm \
@@ -470,6 +472,7 @@ SCM_TESTS = \
tests/import-utils.scm \
tests/inferior.scm \
tests/lint.scm \
+ tests/minetest.scm \
tests/modules.scm \
tests/monads.scm \
tests/nar.scm \
@@ -11314,6 +11314,38 @@ and generate package expressions for all those packages that are not yet
in Guix.
@end table
+@item contentdb
+@cindex minetest
+@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 is often incomplete.
+The commit hash 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 minetest Jeija/mesecons
+@end example
+
+The author name can also be left out:
+
+@example
+guix import minetest 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}.
new file mode 100644
@@ -0,0 +1,456 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos@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 minetest)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 threads)
+ #:use-module (ice-9 hash-table)
+ #: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 ui)
+ #:use-module (guix i18n)
+ #: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)
+ #:export (%default-sort-key
+ %contentdb-api
+ json->package
+ contentdb-fetch
+ elaborate-contentdb-name
+ minetest->guix-package
+ minetest-recursive-import
+ sort-packages))
+
+;; 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))
+
+
+
+;;;
+;;; JSON mappings
+;;;
+
+;; 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)
+ (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)
+ (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))
+
+(define-json-mapping <release> make-release release?
+ json->release
+ ;; If present, a git commit identified by its hash
+ (commit release-commit "commit" string-or-false)
+ (downloads release-downloads) ; integer
+ (id release-id) ; integer
+ (max-minetest-version release-max-minetest-version string-or-false)
+ (min-minetest-version release-min-minetest-version string-or-false)
+ (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") ; bool
+ (name dependency-name) ; string
+ (packages dependency-packages "packages" vector->list)) ; list of strings
+
+;; A structure returned by the /api/packages/?fmt=keys endpoint
+(define-json-mapping <package-keys> make-package-keys package-keys?
+ json->package-keys
+ (author package-keys-author) ; string
+ (name package-keys-name) ; string
+ (type package-keys-type)) ; string
+
+(define (package-mod? package)
+ "Is the ContentDB package PACKAGE a mod?"
+ ;; ContentDB also has ‘games’ and ‘texture packs’.
+ (string=? (package-type package) "mod"))
+
+
+
+;;;
+;;; Manipulating names of packages
+;;;
+;;; There are three kind of names:
+;;;
+;;; * names of guix packages, e.g. minetest-basic-materials.
+;;; * names of mods on ContentDB, e.g. basic_materials
+;;; * a combination of author and mod name on ContentDB, e.g. VanessaE/basic_materials
+;;;
+
+(define (%construct-full-name author name)
+ (string-append author "/" name))
+
+(define (package-full-name package)
+ "Given a <package> object, return the corresponding AUTHOR/NAME string."
+ (%construct-full-name (package-author package) (package-name package)))
+
+(define (package-keys-full-name package)
+ "Given a <package-keys> object, return the corresponding AUTHOR/NAME string."
+ (%construct-full-name (package-keys-author package)
+ (package-keys-name package)))
+
+(define (contentdb->package-name author/name)
+ "Given the AUTHOR/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 (author/name->name author/name))))
+
+(define (author/name->name author/name)
+ "Extract NAME from the AUTHOR/NAME string, or raise an error if AUTHOR/NAME
+is ill-formatted."
+ (match (string-split author/name #\/)
+ ((author name)
+ (when (string-null? author)
+ (leave
+ (G_ "In ~a: author names must consist of at least a single character.~%")
+ author/name))
+ (when (string-null? name)
+ (leave
+ (G_ "In ~a: mod names must consist of at least a single character.~%")
+ author/name))
+ name)
+ ((too many . components)
+ (leave
+ (G_ "In ~a: author names and mod names may not contain forward slashes.~%")
+ author/name))
+ ((name)
+ (if (string-null? name)
+ (leave (G_ "mod names may not be empty.~%"))
+ (leave (G_ "The name of the author is missing in ~a.~%")
+ author/name)))))
+
+(define* (elaborate-contentdb-name name #:key (sort %default-sort-key))
+ "If NAME is an AUTHOR/NAME string, return it. Otherwise, try to determine
+the author and return an appropriate AUTHOR/NAME string. If that fails,
+raise an exception."
+ (if (or (string-contains name "/") (string-null? name))
+ ;; Call 'author/name->name' to verify that NAME seems reasonable
+ ;; and raise an appropriate exception if it isn't.
+ (begin
+ (author/name->name name)
+ name)
+ (let* ((package-keys (contentdb-query-packages name #:sort sort))
+ (correctly-named
+ (filter (lambda (package-key)
+ (string=? name (package-keys-name package-key)))
+ package-keys)))
+ (match correctly-named
+ ((one) (package-keys-full-name one))
+ ((too . many)
+ (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%")
+ name (package-keys-full-name too)
+ (map package-keys-full-name many))
+ (package-keys-full-name too))
+ (()
+ (leave (G_ "No mods with name ~a were found.~%") name))))))
+
+
+
+;;;
+;;; API endpoints
+;;;
+
+(define contentdb-fetch
+ (mlambda (author/name)
+ "Return a <package> record for package AUTHOR/NAME, 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-query-packages q #:key
+ (type "mod")
+ (limit 50)
+ (sort %default-sort-key)
+ (order "desc"))
+ "Search ContentDB for Q (a string). Sort by SORT, in ascending order
+if ORDER is \"asc\" or descending order if ORDER is \"desc\". TYPE must
+be \"mod\", \"game\" or \"txp\", restricting thes search results to
+respectively mods, games and texture packs. Limit to at most LIMIT
+results. The return value is a list of <package-keys> records."
+ ;; XXX does Guile have something for constructing (and, when necessary,
+ ;; escaping) query strings?
+ (define url (string-append (%contentdb-api) "packages/?type=" type
+ "&q=" q "&fmt=keys"
+ "&limit=" (number->string limit)
+ "&order=" order
+ "&sort=" sort))
+ (let ((json (json-fetch url)))
+ (if json
+ (map json->package-keys (vector->list json))
+ (leave
+ (G_ "The package search API doesn't exist anymore.~%")))))
+
+
+
+;; 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)
+ "Compute the hash of FILE."
+ (let-values (((port get-hash) (open-sha256-port)))
+ (write-file file port)
+ (force-output port)
+ (get-hash)))
+
+(define (make-minetest-sexp author/name version repository commit
+ inputs home-page synopsis
+ description media-license license)
+ "Return a S-expression for the minetest package with the given author/NAME,
+VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
+MEDIA-LICENSE and LICENSE."
+ `(package
+ (name ,(contentdb->package-name author/name))
+ (version ,version)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,repository)
+ (commit ,commit)))
+ (sha256
+ (base32
+ ;; The git commit is not always available.
+ ,(and commit
+ (bytevector->nix-base32-string
+ (file-hash
+ (download-git-repository repository
+ `(commit . ,commit)))))))
+ (file-name (git-file-name name version))))
+ (build-system minetest-mod-build-system)
+ ,@(maybe-propagated-inputs (map contentdb->package-name inputs))
+ (home-page ,home-page)
+ (synopsis ,(delete-cr synopsis))
+ (description ,(delete-cr description))
+ (license ,(if (eq? media-license license)
+ license
+ `(list ,media-license ,license)))
+ ;; The Minetest updater (not yet in Guix; it requires not-yet-submitted
+ ;; patches to (guix upstream) that require some work) needs to know both
+ ;; the author name and mod name for efficiency.
+ (properties ,(list 'quasiquote `((upstream-name . ,author/name))))))
+
+(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)))
+
+;; If the default sort key is changed, make sure to modify 'show-help'
+;; in (guix scripts import minetest) appropriately as well.
+(define %default-sort-key "score")
+
+(define* (sort-packages packages #:key (sort %default-sort-key))
+ "Sort PACKAGES by SORT, in descending order."
+ (define package->key
+ (match sort
+ ("score" package-score)
+ ("downloads" package-downloads)))
+ (define (greater x y)
+ (> (package->key x) (package->key y)))
+ (sort-list packages greater))
+
+(define builtin-mod?
+ (let ((%builtin-mods
+ (alist->hash-table
+ (map (lambda (x) (cons x #t))
+ '("beds" "binoculars" "boats" "bones" "bucket" "butterflies"
+ "carts" "creative" "default" "doors" "dungeon_loot" "dye"
+ "env_sounds" "farming" "fire" "fireflies" "flowers"
+ "game_commands" "give_initial_stuff" "map" "mtg_craftguide"
+ "player_api" "screwdriver" "sethome" "sfinv" "spawn" "stairs"
+ "tnt" "vessels" "walls" "weather" "wool" "xpanes")))))
+ (lambda (mod)
+ "Is MOD provided by the default minetest subgame?"
+ (hash-ref %builtin-mods mod))))
+
+(define* (important-dependencies dependencies author/name
+ #:key (sort %default-sort-key))
+ "Return the hard dependencies of AUTHOR/NAME in the association list
+DEPENDENCIES as a list of AUTHOR/NAME strings."
+ (define dependency-list
+ (assoc-ref dependencies author/name))
+ (filter-map
+ (lambda (dependency)
+ (and (not (dependency-optional? dependency))
+ (not (builtin-mod? (dependency-name dependency)))
+ ;; The dependency information contains symbolic names
+ ;; that can be ‘provided’ by multiple mods, so we need to choose one
+ ;; of the implementations.
+ (let* ((implementations
+ (par-map contentdb-fetch (dependency-packages dependency)))
+ ;; Fetching package information about the packages is racy:
+ ;; some packages might be removed from ContentDB between the
+ ;; construction of DEPENDENCIES and the call to
+ ;; 'contentdb-fetch'. So filter out #f.
+ ;;
+ ;; Filter out ‘games’ that include the requested mod -- it's
+ ;; the mod itself we want.
+ (mods (filter (lambda (p) (and=> p package-mod?))
+ implementations))
+ (sorted-mods (sort-packages mods #:sort sort)))
+ (match sorted-mods
+ ((package) (package-full-name package))
+ ((too . many)
+ (warning
+ (G_ "The dependency ~a of ~a has multiple different implementations ~a.~%")
+ (dependency-name dependency)
+ author/name
+ (map package-full-name sorted-mods))
+ (match sort
+ ("score"
+ (warning
+ (G_ "The implementation with the highest score will be choosen!~%")))
+ ("downloads"
+ (warning
+ (G_ "The implementation that has been downloaded the most will be choosen!~%"))))
+ (package-full-name too))
+ (()
+ (warning
+ (G_ "The dependency ~a of ~a does not have any implementation. It will be ignored!~%")
+ (dependency-name dependency) author/name)
+ #f)))))
+ dependency-list))
+
+(define* (%minetest->guix-package author/name #:key (sort %default-sort-key))
+ "Fetch the metadata for AUTHOR/NAME from https://content.minetest.net, and
+return the 'package' S-expression corresponding to that package, or raise an
+exception on failure. On success, also return the upstream dependencies as a
+list of AUTHOR/NAME strings."
+ ;; Call 'author/name->name' to verify that AUTHOR/NAME seems reasonable.
+ (author/name->name author/name)
+ (define package (contentdb-fetch author/name))
+ (unless package
+ (leave (G_ "no package metadata for ~a on ContentDB~%") author/name))
+ (define dependencies (contentdb-fetch-dependencies author/name))
+ (unless dependencies
+ (leave (G_ "no dependency information for ~a on ContentDB~%") author/name))
+ (define release (latest-release author/name))
+ (unless release
+ (leave (G_ "no release of ~a on ContentDB~%") author/name))
+ (define important-upstream-dependencies
+ (important-dependencies dependencies author/name #:sort sort))
+ (values (make-minetest-sexp author/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)
+ (spdx-string->license
+ (package-media-license package))
+ (spdx-string->license
+ (package-license package)))
+ important-upstream-dependencies))
+
+(define minetest->guix-package
+ (memoize %minetest->guix-package))
+
+(define* (minetest-recursive-import author/name #:key (sort %default-sort-key))
+ (define* (minetest->guix-package* author/name #:key repo version)
+ (minetest->guix-package author/name #:sort sort))
+ (recursive-import author/name
+ #:repo->guix-package minetest->guix-package*
+ #:guix-name contentdb->package-name))
@@ -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"
+ "minetest"))
(define (resolve-importer name)
(let ((module (resolve-interface
new file mode 100644
@@ -0,0 +1,117 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxime Devos <maximedevos@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 minetest)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import minetest)
+ #: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-minetest))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ `((sort . ,%default-sort-key)))
+
+(define (show-help)
+ (display (G_ "Usage: guix import minetest 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"))
+ (display (G_ "
+ --sort=KEY when choosing between multiple implementations,
+ choose the one with the highest value for KEY
+ (one of \"score\" (standard) or \"downloads\")"))
+ (newline)
+ (show-bug-report-information))
+
+(define (verify-sort-order sort)
+ "Verify SORT can be used to sort mods by."
+ (unless (member sort '("score" "downloads" "reviews"))
+ (leave (G_ "~a: not a valid key to sort by~%") sort))
+ sort)
+
+(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 minetest")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
+ (option '("sort") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'sort (verify-sort-order arg) result)))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-minetest . 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
+ ((name)
+ (with-error-handling
+ (let* ((sort (assoc-ref opts 'sort))
+ (author/name (elaborate-contentdb-name name #:sort sort)))
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import
+ (filter-map package->definition
+ (minetest-recursive-import author/name #:sort sort))
+ ;; Single import
+ (minetest->guix-package author/name #:sort sort)))))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
@@ -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
new file mode 100644
@@ -0,0 +1,355 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos@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-minetest)
+ #:use-module (guix memoization)
+ #:use-module (guix import minetest)
+ #: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-26)
+ #:use-module (srfi srfi-34)
+ #: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 '())
+ (upstream-name "Author/foo")
+ #: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)
+ (properties
+ ,(list 'quasiquote
+ `((upstream-name . ,upstream-name))))))
+
+(define* (make-package-json #:key
+ (author "Author")
+ (name "foo")
+ (media-license "CC-BY-SA-4.0")
+ (license "LGPL-3.0-or-later")
+ (short-description "synopsis")
+ (long-description "description")
+ (repo "https://example.org/foo.git")
+ (website "https://example.org/foo")
+ (forums 321)
+ (score 987.654)
+ (downloads 123)
+ (type "mod")
+ #:allow-other-keys)
+ `(("author" . ,author)
+ ("content_warnings" . #())
+ ("created_at" . "2018-05-23T19:58:07.422108")
+ ("downloads" . ,downloads)
+ ("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" . ,score)
+ ("screenshots" . #())
+ ("short_description" . ,short-description)
+ ("state" . "APPROVED")
+ ("tags" . #("some" "tags"))
+ ("thumbnail" . null)
+ ("title" . "The name")
+ ("type" . ,type)
+ ("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* (make-packages-keys-json #:key (author "Author")
+ (name "Name")
+ (type "mod"))
+ `(("author" . ,author)
+ ("name" . ,name)
+ ("type" . ,type)))
+
+(define (call-with-packages thunk . argument-lists)
+ ;; Don't reuse results from previous tests.
+ (invalidate-memoization! contentdb-fetch)
+ (invalidate-memoization! minetest->guix-package)
+ (define (scm->json-port scm)
+ (open-input-string (scm->json-string scm)))
+ (define (handle-package url requested-author requested-name . rest)
+ (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))
+ (scm->json-port
+ (apply (match rest
+ (("") make-package-json)
+ (("dependencies" "") make-dependencies-json)
+ (("releases" "") make-releases-json)
+ (_ (error "TODO ~a" rest)))
+ relevant-argument-list)))
+ (define (handle-mod-search sort)
+ ;; Produce search results, sorted by SORT in descending order.
+ (define arguments->key
+ (match sort
+ ("score" (lambda* (#:key (score 987.654) #:allow-other-keys)
+ score))
+ ("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys)
+ downloads))))
+ (define argument-list->key (cut apply arguments->key <>))
+ (define (greater x y)
+ (> (argument-list->key x) (argument-list->key y)))
+ (define sorted-argument-lists (sort-list argument-lists greater))
+ (define* (arguments->json #:key (author "Author") (name "Foo") (type "mod")
+ #:allow-other-keys)
+ (and (string=? type "mod")
+ `(("author" . ,author)
+ ("name" . ,name)
+ ("type" . ,type))))
+ (define argument-list->json (cut apply arguments->json <>))
+ (scm->json-port
+ (list->vector (filter-map argument-list->json sorted-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 #\/))
+ (match components
+ ((author name . rest)
+ (apply handle-package url author name rest))
+ (((? (cut string-prefix? "?type=mod&q=" <>) query))
+ (handle-mod-search
+ (cond ((string-contains query "sort=score") "score")
+ ((string-contains query "sort=downloads") "downloads")
+ (#t (error "search query ~a has unknown sort key"
+ query)))))
+ (_
+ (error "the URL ~a should have an author and name component"
+ url)))))
+ (parameterize ((%contentdb-api "mock://api/"))
+ (thunk))))
+
+(define* (minetest->guix-package* #:key (author "Author") (name "foo")
+ (sort %default-sort-key)
+ #:allow-other-keys)
+ (minetest->guix-package (string-append author "/" name) #:sort sort))
+
+(define (imported-package-sexp* primary-arguments . secondary-arguments)
+ "Ask the importer to import a package specified by PRIMARY-ARGUMENTS,
+during a dynamic where that package and the packages specified by
+SECONDARY-ARGUMENTS are available on ContentDB."
+ (apply call-with-packages
+ (lambda ()
+ ;; The memoization cache is reset by call-with-packages
+ (apply minetest->guix-package* primary-arguments))
+ primary-arguments
+ secondary-arguments))
+
+(define (imported-package-sexp . extra-arguments)
+ "Ask the importer to import a package specified by EXTRA-ARGUMENTS,
+during a dynamic extent where that package is available on ContentDB."
+ (imported-package-sexp* 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)))
+
+(define-syntax-rule (test-package* test-case primary-arguments extra-arguments
+ ...)
+ (test-equal test-case
+ (apply make-package-sexp primary-arguments)
+ (imported-package-sexp* primary-arguments extra-arguments ...)))
+
+(test-begin "minetest")
+
+
+;; Package names
+(test-package "minetest->guix-package")
+(test-package "minetest->guix-package, _ → - in package name"
+ #:name "foo_bar"
+ #:guix-name "minetest-foo-bar"
+ #:upstream-name "Author/foo_bar")
+
+(test-equal "elaborate names, unambigious"
+ "Jeija/mesecons"
+ (call-with-packages
+ (cut elaborate-contentdb-name "mesecons")
+ '(#:name "mesecons" #:author "Jeija")
+ '(#:name "something" #:author "else")))
+
+(test-equal "elaborate name, ambigious (highest score)"
+ "Jeija/mesecons"
+ (call-with-packages
+ ;; #:sort "score" is the default
+ (cut elaborate-contentdb-name "mesecons")
+ '(#:name "mesecons" #:author "Jeijc" #:score 777)
+ '(#:name "mesecons" #:author "Jeijb" #:score 888)
+ '(#:name "mesecons" #:author "Jeija" #:score 999)))
+
+
+(test-equal "elaborate name, ambigious (most downloads)"
+ "Jeija/mesecons"
+ (call-with-packages
+ (cut elaborate-contentdb-name "mesecons" #:sort "downloads")
+ '(#:name "mesecons" #:author "Jeijc" #:downloads 777)
+ '(#:name "mesecons" #:author "Jeijb" #:downloads 888)
+ '(#:name "mesecons" #:author "Jeija" #:downloads 999)))
+
+
+;; Determining the home page
+(test-package "minetest->guix-package, website is used as home page"
+ #:home-page "web://site"
+ #:website "web://site")
+(test-package "minetest->guix-package, if absent, the forum is used"
+ #:home-page '(minetest-topic 628)
+ #:forums 628
+ #:website 'null)
+(test-package "minetest->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 "minetest->guix-package, all home page information absent"
+ #:home-page #f
+ #:forums 'null
+ #:website 'null
+ #:repo 'null)
+
+
+
+;; Dependencies
+(test-package* "minetest->guix-package, unambigious dependency"
+ (list #:requirements '(("mesecons" #f
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '("minetest-mesecons"))
+ (list #:author "Jeija" #:name "mesecons")
+ (list #:author "some-modpack" #:name "containing-mese" #:type "modpack"))
+
+(test-package* "minetest->guix-package, ambigious dependency (highest score)"
+ (list #:name "frobnicate"
+ #:guix-name "minetest-frobnicate"
+ #:upstream-name "Author/frobnicate"
+ #:requirements '(("frob" #f
+ ("Author/foo" "Author/bar")))
+ ;; #:sort "score" is the default
+ #:inputs '("minetest-bar"))
+ (list #:author "Author" #:name "foo" #:score 0)
+ (list #:author "Author" #:name "bar" #:score 9999))
+
+(test-package* "minetest->guix-package, ambigious dependency (most downloads)"
+ (list #:name "frobnicate"
+ #:guix-name "minetest-frobnicate"
+ #:upstream-name "Author/frobnicate"
+ #:requirements '(("frob" #f
+ ("Author/foo" "Author/bar")))
+ #:inputs '("minetest-bar")
+ #:sort "downloads")
+ (list #:author "Author" #:name "foo" #:downloads 0)
+ (list #:author "Author" #:name "bar" #:downloads 9999))
+
+(test-package "minetest->guix-package, optional dependency"
+ #:requirements '(("mesecons" #t
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '())
+
+
+;; License
+(test-package "minetest->guix-package, identical licenses"
+ #:guix-license 'license:lgpl3+
+ #:license "LGPL-3.0-or-later"
+ #:media-license "LGPL-3.0-or-later")
+
+;; Sorting
+(let* ((make-package
+ (lambda arguments
+ (json->package (apply make-package-json arguments))))
+ (x (make-package #:score 0))
+ (y (make-package #:score 1))
+ (z (make-package #:score 2)))
+ (test-equal "sort-packages, already sorted"
+ (list z y x)
+ (sort-packages (list z y x)))
+ (test-equal "sort-packages, reverse"
+ (list z y x)
+ (sort-packages (list x y z))))
+
+(test-end "minetest")
--
2.32.0