diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/dune-build-system.scm | 8 | ||||
| -rw-r--r-- | guix/build/minetest-build-system.scm | 229 |
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 |