457 lines
18 KiB
Scheme
457 lines
18 KiB
Scheme
|
;;; 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))
|