diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | doc/guix.texi | 32 | ||||
| -rw-r--r-- | guix/import/minetest.scm | 456 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/import/minetest.scm | 117 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/minetest.scm | 355 |
7 files changed, 966 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 344b7423c5..327d3f9961 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 \ diff --git a/doc/guix.texi b/doc/guix.texi index d6197d3743..241a1824ec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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}. diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm new file mode 100644 index 0000000000..e1f8487b75 --- /dev/null +++ b/guix/import/minetest.scm @@ -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)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index f53d1ac1f4..b369a362d0 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" + "minetest")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/minetest.scm b/guix/scripts/import/minetest.scm new file mode 100644 index 0000000000..5f204d90fc --- /dev/null +++ b/guix/scripts/import/minetest.scm @@ -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~%")))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 14324b25de..1eee82be53 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/minetest.scm b/tests/minetest.scm new file mode 100644 index 0000000000..6ae476fe5f --- /dev/null +++ b/tests/minetest.scm @@ -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") |