summaryrefslogtreecommitdiff
path: root/guix/import/minetest.scm
blob: abddd885ee97b0c4db75d672515315c79976eb8c (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
;;; 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 packages) #:prefix package:)
  #:use-module (guix upstream)
  #: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 git-download) #:prefix download:)
  #:use-module (guix store)
  #:export (%default-sort-key
            %contentdb-api
            json->package
            contentdb-fetch
            elaborate-contentdb-name
            minetest-package?
            latest-minetest-release
            minetest->guix-package
            minetest-recursive-import
            sort-packages
            %minetest-updater))

;; 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 ambiguous, 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 the 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 ,(beautify-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)))

(define (release-version release)
  "Guess the version of RELEASE from the release title."
  (define title (release-title release))
  (if (string-prefix? "v" title)
      ;; Remove "v" prefix from release titles like ‘v1.0.1’.
      (substring title 1)
      title))

(define (version-style version)
  "Determine the kind of version number VERSION is -- a date, or a conventional
conventional version number."
  (define dots? (->bool (string-index version #\.)))
  (define hyphens? (->bool (string-index version #\-)))
  (match (cons dots? hyphens?)
    ((#true . #false) 'regular) ; something like "0.1"
    ((#false . #false) 'regular) ; single component version number
    ((#true . #true) 'regular) ; result of 'git-version'
    ((#false . #true) 'date))) ; something like "2021-01-25"

;; 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-version release)
                              (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))

(define (minetest-package? pkg)
  "Is PKG a Minetest mod on ContentDB?"
  (and (string-prefix? "minetest-" (package:package-name pkg))
       (assq-ref (package:package-properties pkg) 'upstream-name)))

(define (latest-minetest-release pkg)
  "Return an <upstream-source> for the latest release of the package PKG,
or #false if the latest release couldn't be determined."
  (define author/name
    (assq-ref (package:package-properties pkg) 'upstream-name))
  (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f?
  (define release (latest-release author/name))
  (define source (package:package-source pkg))
  (and contentdb-package release
       (release-commit release) ; not always set
       ;; Only continue if both the old and new version number are both
       ;; dates or regular version numbers, as two different styles confuses
       ;; the logic for determining which version is newer.
       (eq? (version-style (release-version release))
            (version-style (package:package-version pkg)))
       (upstream-source
        (package (package:package-name pkg))
        (version (release-version release))
        (urls (list (download:git-reference
                     (url (package-repository contentdb-package))
                     (commit (release-commit release))))))))

(define %minetest-updater
  (upstream-updater
    (name 'minetest)
    (description "Updater for Minetest packages on ContentDB")
    (pred minetest-package?)
    (latest latest-minetest-release)))