Merge branch 'master' into core-updates-frozen

2 files changed, 235 insertions, 2 deletions

diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm
index 7e2ec1e3e1..6a0c2593ac 100644
--- a/guix/build/dune-build-system.scm
+++ b/guix/build/dune-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
 ;;; Copyright © 2019 Gabriel Hondet <gabrielhondet@gmail.com>
+;;; Copyright © 2021 pukkamustard <pukkamustard@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,11 +32,14 @@
 ;; Code:
 
 (define* (build #:key (build-flags '()) (jbuild? #f)
-                (use-make? #f) (package #f) #:allow-other-keys)
+                (use-make? #f) (package #f)
+                (profile "release") #:allow-other-keys)
   "Build the given package."
   (let ((program (if jbuild? "jbuilder" "dune")))
     (apply invoke program "build" "@install"
-           (append (if package (list "-p" package) '()) build-flags)))
+           (append (if package (list "-p" package) '())
+                   `("--profile" ,profile)
+                   build-flags)))
   #t)
 
 (define* (check #:key (test-flags '()) (test-target "test") tests?
diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm
new file mode 100644
index 0000000000..477cc3d1d0
--- /dev/null
+++ b/guix/build/minetest-build-system.scm
@@ -0,0 +1,229 @@
+;;; 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 build minetest-build-system)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module ((guix build copy-build-system) #:prefix copy:)
+  #:export (%standard-phases
+            mod-install-plan minimise-png read-mod-name check))
+
+;; (guix build copy-build-system) does not export 'install'.
+(define copy:install
+  (assoc-ref copy:%standard-phases 'install))
+
+(define (mod-install-plan mod-name)
+  `(("." ,(string-append "share/minetest/mods/" mod-name)
+     ;; Only install files that will actually be used at run time.
+     ;; This can save a little disk space.
+     ;;
+     ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt>
+     ;; for an incomple list of files that can be found in mods.
+     #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt"
+                "description.txt")
+     #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$"
+                       ".mts$"))))
+
+(define* (guess-mod-name #:key inputs #:allow-other-keys)
+  "Try to determine the name of the mod or modpack that is being built.
+If it is unknown, make an educated guess."
+  ;; Minetest doesn't care about the directory names in "share/minetest/mods"
+  ;; so there is no technical problem if the directory names don't match
+  ;; the mod names.  The directory can appear in the GUI if the modpack
+  ;; doesn't have the 'name' set though, so try to make a guess.
+  (define (guess)
+    (let* ((source (assoc-ref inputs "source"))
+           ;; Don't retain a reference to the store.
+           (file-name (strip-store-file-name source))
+           ;; The "minetest-" prefix is not informative, so strip it.
+           (file-name (if (string-prefix? "minetest-" file-name)
+                          (substring file-name (string-length "minetest-"))
+                          file-name))
+           ;; Strip "-checkout" suffixes of git checkouts.
+           (file-name (if (string-suffix? "-checkout" file-name)
+                          (substring file-name
+                                     0
+                                     (- (string-length file-name)
+                                        (string-length "-checkout")))
+                          file-name))
+           (first-dot (string-index file-name #\.))
+           ;; If the source code is in an archive (.tar.gz, .zip, ...),
+           ;; strip the extension.
+           (file-name (if first-dot
+                          (substring file-name 0 first-dot)
+                          file-name)))
+      (format (current-error-port)
+              "warning: the modpack ~a did not set 'name' in 'modpack.conf'~%"
+              file-name)
+      file-name))
+  (cond ((file-exists? "mod.conf")
+         ;; Mods must have 'name' set in "mod.conf", so don't guess.
+         (read-mod-name "mod.conf"))
+        ((file-exists? "modpack.conf")
+         ;; While it is recommended to have 'name' set in 'modpack.conf',
+         ;; it is optional, so guess a name if necessary.
+         (read-mod-name "modpack.conf" guess))
+        (#t (guess))))
+
+(define* (install #:key inputs #:allow-other-keys #:rest arguments)
+  (apply copy:install
+         #:install-plan (mod-install-plan (apply guess-mod-name arguments))
+         arguments))
+
+(define %png-magic-bytes
+  ;; Magic bytes of PNG images, see ‘5.2 PNG signatures’ in
+  ;; ‘Portable Network Graphics (PNG) Specification (Second Edition)’
+  ;; on <https://www.w3.org/TR/PNG/>.
+  #vu8(137 80 78 71 13 10 26 10))
+
+(define png-file?
+  ((@@ (guix build utils) file-header-match) %png-magic-bytes))
+
+(define* (minimise-png #:key inputs native-inputs #:allow-other-keys)
+  "Minimise PNG images found in the working directory."
+  (define optipng (which "optipng"))
+  (define (optimise image)
+    (format #t "Optimising ~a~%" image)
+    (make-file-writable (dirname image))
+    (make-file-writable image)
+    (define old-size (stat:size (stat image)))
+    ;; The mod "technic" has a file "technic_music_player_top.png" that
+    ;; actually is a JPEG file, see
+    ;; <https://github.com/minetest-mods/technic/issues/590>.
+    (if (png-file? image)
+        (invoke optipng "-o4" "-quiet" image)
+        (format #t "warning: skipping ~a because it's not actually a PNG image~%"
+                image))
+    (define new-size (stat:size (stat image)))
+    (values old-size new-size))
+  (define files (find-files "." ".png$"))
+  (let loop ((total-old-size 0)
+             (total-new-size 0)
+             (images (find-files "." ".png$")))
+    (cond ((pair? images)
+           (receive (old-size new-size)
+               (optimise (car images))
+             (loop (+ total-old-size old-size)
+                   (+ total-new-size new-size)
+                   (cdr images))))
+          ((= total-old-size 0)
+           (format #t "There were no PNG images to minimise."))
+          (#t
+           (format #t "Minimisation reduced size of images by ~,2f% (~,2f MiB to ~,2f MiB)~%"
+                   (* 100.0 (- 1 (/ total-new-size total-old-size)))
+                   (/ total-old-size (expt 1024 2))
+                   (/ total-new-size (expt 1024 2)))))))
+
+(define name-regexp (make-regexp "^name[ ]*=(.+)$"))
+
+(define* (read-mod-name mod.conf #:optional not-found)
+  "Read the name of a mod from MOD.CONF.  If MOD.CONF
+does not have a name field and NOT-FOUND is #false, raise an
+error.  If NOT-FOUND is TRUE, call NOT-FOUND instead."
+  (call-with-input-file mod.conf
+    (lambda (port)
+      (let loop ()
+        (define line (read-line port))
+        (if (eof-object? line)
+            (if not-found
+                (not-found)
+                (error "~a does not have a 'name' field" mod.conf))
+            (let ((match (regexp-exec name-regexp line)))
+              (if (regexp-match? match)
+                  (string-trim-both (match:substring match 1) #\ )
+                  (loop))))))))
+
+(define* (check #:key outputs tests? #:allow-other-keys)
+  "Test whether the mod loads.  The mod must first be installed first."
+  (define (all-mod-names directories)
+    (append-map
+     (lambda (directory)
+       (map read-mod-name (find-files directory "mod.conf")))
+     directories))
+  (when tests?
+    (mkdir "guix_testworld")
+    ;; Add the mod to the mod search path, such that Minetest can find it.
+    (setenv "MINETEST_MOD_PATH"
+            (list->search-path-as-string
+             (cons
+              (string-append (assoc-ref outputs "out") "/share/minetest/mods")
+              (search-path-as-string->list
+               (or (getenv "MINETEST_MOD_PATH") "")))
+             ":"))
+    (with-directory-excursion "guix_testworld"
+      (setenv "HOME" (getcwd))
+      ;; Create a world in which all mods are loaded.
+      (call-with-output-file "world.mt"
+        (lambda (port)
+          (display
+           "gameid = minetest
+world_name = guix_testworld
+backend = sqlite3
+player_backend = sqlite3
+auth_backend = sqlite3
+" port)
+          (for-each
+           (lambda (mod)
+             (format port "load_mod_~a = true~%" mod))
+           (all-mod-names (search-path-as-string->list
+                           (getenv "MINETEST_MOD_PATH"))))))
+      (receive (port pid)
+          ((@@ (guix build utils) open-pipe-with-stderr)
+           "xvfb-run" "--" "minetest" "--info" "--world" "." "--go")
+        (format #t "Started Minetest with all mods loaded for testing~%")
+        ;; Scan the output for error messages.
+        ;; When the player has joined the server, stop minetest.
+        (define (error? line)
+          (and (string? line)
+               (string-contains line ": ERROR[")))
+        (define (stop? line)
+          (and (string? line)
+               (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game.")))
+        (let loop ()
+          (match (read-line port)
+            ((? error? line)
+             (error "minetest raised an error: ~a" line))
+            ((? stop?)
+             (kill pid SIGINT)
+             (close-port port)
+             (waitpid pid))
+            ((? string? line)
+             (display line)
+             (newline)
+             (loop))
+            ((? eof-object?)
+             (error "minetest didn't start"))))))))
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'bootstrap)
+    (delete 'configure)
+    (add-before 'build 'minimise-png minimise-png)
+    (delete 'build)
+    (delete 'check)
+    (replace 'install install)
+    ;; The 'check' phase requires the mod to be installed,
+    ;; so move the 'check' phase after the 'install' phase.
+    (add-after 'install 'check check)))
+
+;;; minetest-build-system.scm ends here