;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Maxime Devos ;;; ;;; 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 . (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 ;; . (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 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 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 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 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 object, return the corresponding AUTHOR/NAME string." (%construct-full-name (package-author package) (package-name package))) (define (package-keys-full-name package) "Given a 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 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 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 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 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)) ;; A mod can have multiple dependencies implemented by the same mod, ;; so remove duplicate mod names. (define (filter-deduplicate-map f list) (delete-duplicates (filter-map f list))) (filter-deduplicate-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))