me
/
guix
Archived
1
0
Fork 0
Code

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.

Signed-off-by: Leo Prikler <leo.prikler@student.tugraz.at>
Maxime Devos 2021-08-10 17:07:20 +02:00 committed by Leo Prikler
parent d08455934c
commit 467e874a86
No known key found for this signature in database
GPG Key ID: 442A84B8C70E2F87
7 changed files with 966 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile.am
View File

@ -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 \

32
doc/guix.texi
View File

@ -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}.

456
guix/import/minetest.scm 100644
View File

@ -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))

3
guix/scripts/import.scm
View File

@ -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

117
guix/scripts/import/minetest.scm 100644
View File

@ -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~%"))))))

1
po/guix/POTFILES.in
View File

@ -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

355
tests/minetest.scm 100644
View File

@ -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")