guix-play/guix/build/minetest-build-system.scm

;;; 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 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 (ice-9 exceptions)
  #: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" "config.txt" "_config.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* (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[[:space:]]*=[[:space:]]*([[:graph:]]+)[[:space:]]*$"))

(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 ((has-errors? #f))
          (match `(,(read-line port) ,has-errors?)
            (((? error? line) _)
             (display line)
             (newline)
             (loop #t))
            (((? stop?) #f)
             (kill pid SIGINT)
             (close-port port)
             (waitpid pid))
            (((? eof-object?) #f)
             (error "minetest didn't start"))
            (((or (? stop?) (? eof-object?)) #t)
             (error "minetest raised an error"))
            (((? string? line) has-error?)
             (display line)
             (newline)
             (loop has-error?))))))))

(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