Merge branch 'master' into core-updates-frozen

1 files changed, 456 insertions, 0 deletions

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