From f4c04f37757d1cda4fae9aa91ad72bc633b83094 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 26 Sep 2021 16:03:49 -0400
Subject: cli: Add bundle subcommand.

---
 Makefile.am              |   3 +-
 chickadee/cli.scm        |   1 +
 chickadee/cli/bundle.scm | 397 +++++++++++++++++++++++++++++++++++++++++++++++
 doc/chickadee.texi       | 124 +++++++++++++++
 4 files changed, 524 insertions(+), 1 deletion(-)
 create mode 100644 chickadee/cli/bundle.scm

diff --git a/Makefile.am b/Makefile.am
index aed1535..3f7b7d0 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -95,7 +95,8 @@ SOURCES = 					\
   chickadee/scripting.scm			\
   chickadee.scm					\
   chickadee/cli.scm				\
-  chickadee/cli/play.scm
+  chickadee/cli/play.scm			\
+  chickadee/cli/bundle.scm
 
 TESTS =						\
   tests/math/vector.scm
diff --git a/chickadee/cli.scm b/chickadee/cli.scm
index 66f2093..2e104fb 100644
--- a/chickadee/cli.scm
+++ b/chickadee/cli.scm
@@ -42,6 +42,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"
 Run SUBCOMMAND with ARGS
 
 Valid subcommands:
+* bundle
 * play~%")
   (exit 1))
 
diff --git a/chickadee/cli/bundle.scm b/chickadee/cli/bundle.scm
new file mode 100644
index 0000000..a495236
--- /dev/null
+++ b/chickadee/cli/bundle.scm
@@ -0,0 +1,397 @@
+(define-module (chickadee cli bundle)
+  #:declarative? #f
+  #:use-module (chickadee cli)
+  #:use-module (chickadee cli play)
+  #:use-module (chickadee config)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:use-module (system base compile)
+  #:export (chickadee-bundle
+            %default-config))
+
+(define (regular-file? file-name)
+  (eq? (stat:type (lstat file-name)) 'regular))
+
+(define (scan-for-libraries directories)
+  (map (lambda (dir)
+         (cons dir
+               (scandir dir
+                        (lambda (file-name)
+                          (and (not (string=? file-name "."))
+                               (not (string=? file-name ".."))
+                               (regular-file? (string-append dir "/" file-name))
+                               (string-contains file-name ".so"))))))
+       directories))
+
+(define (soname lib)
+  (string-append "lib" lib ".so"))
+
+(define (find-lib lib-name libraries)
+  (let ((prefix (soname lib-name)))
+    (let loop ((libraries libraries))
+      (match libraries
+        (() (error "no shared library found for" lib-name))
+        (((dir . files) . rest)
+         (or (let ((file (find (lambda (file-name)
+                                 (string-prefix? prefix file-name))
+                               files)))
+               (and file (string-append dir "/" file)))
+             (loop rest)))))))
+
+(define (find-bin name directories)
+  (let loop ((dirs directories))
+    (match dirs
+      (() (error "cannot find binary" name))
+      ((dir . rest)
+       (or (let ((bin-name (string-append dir "/" name)))
+             (and (file-exists? bin-name) bin-name))
+           (loop rest))))))
+
+(define (library-version-number lib file-name)
+  (string-drop (basename file-name)
+               (string-length (string-append (soname lib) "."))))
+
+(define (copy-lib lib file-name destdir)
+  (define (scope-lib file-name)
+    (string-append destdir "/lib/" file-name))
+  (let* ((so (soname lib))
+         (version (string-split (library-version-number lib file-name) #\.))
+         (base-file-name (basename file-name))
+         (dest-file-name (scope-lib base-file-name)))
+    (format #t "copy ~a → ~a~%"
+            file-name dest-file-name)
+    (copy-file file-name dest-file-name)
+    (format #t "symlink ~a → ~a~%" (scope-lib so) base-file-name)
+    (symlink base-file-name (scope-lib so))
+    ;; Create symlinks for all the possible version number fragments.
+    (for-each (lambda (n)
+                (let ((link-name (scope-lib
+                                  (string-append so "."
+                                                 (string-join (take version
+                                                                    (+ n 1))
+                                                              ".")))))
+                  (format #t "symlink ~a → ~a~%" link-name base-file-name)
+                  (symlink base-file-name link-name)))
+              (iota (- (length version) 1)))))
+
+(define (root-module)
+  (resolve-module '() #f #f #:ensure #f))
+
+(define (loaded-modules)
+  (define (scan-submodules module)
+    (hash-fold (lambda (k m memo)
+                 (if (module-filename m)
+                     (cons (module-filename m)
+                           (append (scan-submodules m)
+                                   memo))
+                     (append (scan-submodules m) memo)))
+               '()
+               (module-submodules module)))
+  (delete-duplicates (cons* "ice-9/eval.scm"
+                            "ice-9/i18n.scm"
+                            "ice-9/posix.scm"
+                            "ice-9/psyntax-pp.scm"
+                            "ice-9/quasisyntax.scm"
+                            "ice-9/match.upstream.scm"
+                            "ice-9/networking.scm"
+                            "ice-9/r6rs-libraries.scm"
+                            "ice-9/r7rs-libraries.scm"
+                            (scan-submodules (root-module)))
+                     string=?))
+
+(define (scm->go file-name)
+  (string-append (substring file-name 0 (- (string-length file-name) 4)) ".go"))
+
+;; Gather up the compiled/source files of all the modules that are
+;; being used right now.
+(define (shake-tree)
+  (map (lambda (f)
+         (list f
+               (search-path %load-path f)
+               (search-path %load-compiled-path (scm->go f))))
+       (sort (loaded-modules) string<)))
+
+;; Snarfed from Guix
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
+;; Also snarfed from Guix, with some simplifications.
+(define* (copy-recursively source destination)
+  (define strip-source
+    (let ((len (string-length source)))
+      (lambda (file)
+        (substring file len))))
+
+  (file-system-fold (const #t)                    ; enter?
+                    (lambda (file stat result)    ; leaf
+                      (let ((dest (string-append destination
+                                                 (strip-source file))))
+                        (format #t "copy ~a → ~a~%" file dest)
+                        (case (stat:type stat)
+                          ((symlink)
+                           (let ((target (readlink file)))
+                             (symlink target dest)))
+                          (else
+                           (copy-file file dest)))))
+                    (lambda (dir stat result)     ; down
+                      (let ((target (string-append destination
+                                                   (strip-source dir))))
+                        (mkdir-p target)))
+                    (lambda (dir stat result)     ; up
+                      result)
+                    (const #t)                    ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port) "i/o error: ~a: ~a~%"
+                              file (strerror errno))
+                      #f)
+                    #t
+                    source
+                    lstat))
+
+;; Once again, snarfed from Guix.
+(define* (delete-file-recursively dir
+                                  #:key follow-mounts?)
+  (let ((dev (stat:dev (lstat dir))))
+    (file-system-fold (lambda (dir stat result)    ; enter?
+                        (or follow-mounts?
+                            (= dev (stat:dev stat))))
+                      (lambda (file stat result)   ; leaf
+                        (delete-file file))
+                      (const #t)                   ; down
+                      (lambda (dir stat result)    ; up
+                        (rmdir dir))
+                      (const #t)                   ; skip
+                      (lambda (file stat errno result)
+                        (format (current-error-port)
+                                "warning: failed to delete ~a: ~a~%"
+                                file (strerror errno)))
+                      #t
+                      dir
+
+                      ;; Don't follow symlinks.
+                      lstat)))
+
+(define (shell-escape str)
+  (let ((n (string-length str)))
+    (list->string
+     (cons #\'
+           (let loop ((i 0))
+             (cond
+              ((= i n)
+               '(#\'))
+              ((eqv? (string-ref str i) #\')
+               (cons* #\' #\\ #\' #\'
+                      (loop (+ i 1))))
+              (else
+               (cons (string-ref str i)
+                     (loop (+ i 1))))))))))
+
+(define (install-modules destdir)
+  (let ((v (string-append (major-version) ".0")))
+    (for-each (match-lambda
+                ((suffix source compiled)
+                 (let (;; (scm-dest (string-append destdir "/share/guile/" v "/"
+                       ;;                          suffix))
+                       (go-dest (string-append destdir "/lib/guile/" v "/ccache/"
+                                               (scm->go suffix))))
+                   ;; (mkdir-p (dirname scm-dest))
+                   (mkdir-p (dirname go-dest))
+                   ;;(format #t "copy ~a → ~a~%" source scm-dest)
+                   ;;(copy-file source scm-dest)
+                   (when compiled
+                     (format #t "copy ~a → ~a~%" compiled go-dest)
+                     (copy-file compiled go-dest)))))
+              (shake-tree))))
+
+(define (install-libraries destdir names system-libraries)
+  (for-each (lambda (lib)
+              (let ((file-name (find-lib lib system-libraries)))
+                (copy-lib lib file-name destdir)))
+            names))
+
+(define (install-guile destdir directories)
+  (let ((src (find-bin "guile" directories))
+        (dest (string-append destdir "/bin/guile")))
+    (format #t "copy ~a → ~a~%" src dest)
+    (copy-file src dest)))
+
+(define (install-assets dirs destdir)
+  (for-each (lambda (dir)
+              (let ((target (string-append destdir "/" dir)))
+                (copy-recursively dir target)))
+            dirs))
+
+(define (install-chickadee-data destdir)
+  (let ((sharedir (string-append destdir "/share/chickadee")))
+    (mkdir sharedir)
+    (copy-recursively %datadir sharedir)))
+
+(define (install-init.scm code method destdir)
+  (let ((init (string-append destdir "/init.scm")))
+    (format #t "copy ~a → ~a~%" code init)
+    (copy-file code init)
+    (case method
+      ((play)
+       (let ((module (resolve-module '(chickadee-bundler) #f)))
+         (beautify-user-module! module)
+         ;; Need to load all of the default modules for `chickadee play` so
+         ;; that the tree shaker won't miss anything.
+         (for-each (lambda (name)
+                     (module-use! module (resolve-interface name)))
+                   %default-modules)
+         ;; Compile the main file to load all of the modules that it uses
+         ;; without executing the code.
+         (compile-file init #:env module)))
+      ((manual)
+       (compile-file init)))))
+
+(define (install-launcher name method args destdir)
+  (let ((exe (string-append destdir "/" name))
+        (args (case method
+                ((play)
+                 (let ((exp (with-output-to-string
+                              (lambda ()
+                                (write '(use-modules (chickadee cli play)))
+                                (write `(chickadee-play "init.scm" ,@args))))))
+                   (string-append "-c " (shell-escape exp))))
+                ((manual)
+                 "--no-auto-compile init.scm")
+                (else
+                 (error "unsupported launch method" method)))))
+    (format #t "install ~a~%" exe)
+    (call-with-output-file exe
+      (lambda (port)
+        (format port "#!/bin/sh
+
+rootdir=`dirname $(realpath $0)`
+export PATH=\"$rootdir/bin:$PATH\"
+export LD_LIBRARY_PATH=\"$rootdir/lib\"
+export GUILE_LOAD_PATH=\"$rootdir/share/guile/3.0\"
+export GUILE_LOAD_COMPILED_PATH=\"$rootdir/lib/guile/3.0/ccache\"
+export CHICKADEE_DATADIR=\"$rootdir/share/chickadee\"
+cd $rootdir
+exec bin/guile ~a
+" args)))
+    (chmod exe #o755)))
+
+(define %default-config
+  '((asset-directories . ())
+    (binary-directories . ("/usr/bin"))
+    (bundle-name . "chickadee-bundle")
+    (launcher-name . "launch-game")
+    (libraries . ("ffi"
+                  "FLAC"
+                  "freetype"
+                  "gc"
+                  "gmp"
+                  "guile-3.0"
+                  "jbig"
+                  "jpeg"
+                  "mpg123"
+                  "ogg"
+                  "openal"
+                  "png16"
+                  "readline"
+                  "SDL2-2.0"
+                  "SDL2_image-2.0"
+                  "sndfile"
+                  "sndio"
+                  "tiff"
+                  "tinfo"
+                  "unistring"
+                  "vorbis"
+                  "vorbisenc"
+                  "vorbisfile"
+                  "webp"
+                  "z"))
+    (library-directories . ("/lib"
+                            "/lib64"
+                            "/lib/x86_64-linux-gnu"
+                            "/usr/lib"
+                            "/usr/lib/x86_64-linux-gnu"))
+    (method . play)
+    (play-args . ())))
+
+(define %tmpdir (or (getenv "TMPDIR") "/tmp"))
+
+(define (make-bundle user-config)
+  (let* ((config (append user-config %default-config))
+         (name (assq-ref config 'bundle-name))
+         (archive (string-append name ".tar.gz"))
+         (args (assq-ref config 'play-args))
+         (assets (assq-ref config 'asset-directories))
+         (bindirs (assq-ref config 'binary-directories))
+         (code (assq-ref config 'code))
+         (tmpdir (mkdtemp (string-append %tmpdir "/chickadee-bundle-XXXXXX")))
+         (destdir (string-append tmpdir "/" name))
+         (launcher (assq-ref config 'launcher-name))
+         (libraries (assq-ref config 'libraries))
+         (libdirs (assq-ref config 'library-directories))
+         (method (assq-ref config 'method)))
+    (mkdir destdir)
+    (mkdir (string-append destdir "/bin"))
+    (mkdir (string-append destdir "/lib"))
+    (mkdir (string-append destdir "/share"))
+    (install-init.scm code method destdir)
+    (install-launcher launcher method args destdir)
+    (install-assets assets destdir)
+    (install-guile destdir bindirs)
+    (install-chickadee-data destdir)
+    (install-libraries destdir libraries (scan-for-libraries libdirs))
+    (install-modules destdir)
+    (format #t "create ~a~%" archive)
+    (unless (zero? (system* "tar" "czf" archive "-C" tmpdir "chickadee-bundle"))
+      (format (current-error-port) "failed to create ~a archive~%" archive)
+      (exit 1))
+    (delete-file-recursively tmpdir)))
+
+(define (display-help-and-exit)
+  (format #t "Usage: chickadee bundle [OPTIONS] [FILE]~%
+Create a redistributable binary tarball using the settings in FILE, or
+'bundle.scm' by default.~%")
+  (display "
+  --help                 display this help and exit")
+  (newline)
+  (exit 1))
+
+(define %options
+  (list (option '("help") #f #f
+                (lambda (opt name arg result)
+                  (display-help-and-exit)))))
+
+(define %default-options '())
+
+(define (chickadee-bundle . args)
+  (let ((opts (simple-args-fold args %options %default-options)))
+    (match (operands opts)
+      (()
+       (make-bundle (primitive-load "bundle.scm")))
+      ((file-name)
+       (make-bundle (primitive-load file-name)))
+      (_
+       (leave "too many arguments specified. just pass a Scheme file name.")))))
diff --git a/doc/chickadee.texi b/doc/chickadee.texi
index 0585688..f561bae 100644
--- a/doc/chickadee.texi
+++ b/doc/chickadee.texi
@@ -182,6 +182,7 @@ line utility to make it easier to get started.
 
 @menu
 * Invoking chickadee play::     Run Chickadee programs
+* Invoking chickadee bundle::   Create redistributable binary bundles
 @end menu
 
 @node Invoking chickadee play
@@ -279,6 +280,129 @@ REPL server.
 
 @end table
 
+@node Invoking chickadee bundle
+@section Invoking @command{chickadee bundle}
+
+Distributing games is difficult.  While Chickadee games are free
+software, it would be far too burdensome on the player to ask them to
+compile a game from source in order to try it out.  Many potential
+players will simply not even try.  Players expect to be able to
+download a compressed archive, extract it, and play.  If there are any
+more steps than that then the chances of the game being played drop
+dramatically.  If you can't beat 'em, join 'em.  The
+@command{chickadee bundle} tool creates redistributable binary bundles
+by combining the game code and assets with shared libraries and
+executables from the host operating system.
+
+Bundling is currently only supported on Linux.  In the future, it may
+be possible to bundle on MacOS.  Patches very much welcome for that.
+
+It should be noted that bundling is a problematic way to distribute
+software.  All of the libraries that the bundled application includes
+are separated from the distribution that was so carefully making sure
+that they stay up-to-date with regard to security patches.  The
+bundled libraries are frozen in time, vulnerabilities and all.
+Unfortunately, the release model used by the most popular
+distributions, while wonderful for stable, mature software, does not
+fit the needs of game distribution at all.  So, we compromise, knowing
+that most games are only played for only a short amount of time before
+being disposed.  Perhaps, in time, the Linux world will shift to using
+more robust package management solutions such as
+@url{https://guix.gnu.org, GNU Guix} which support long-term
+maintenance of stable software as well as the ``fire and forget''
+nature of game releases.  And maybe a game made with Chickadee will
+become so popular that major distributions decide to package it, but
+let's get back to reality.
+
+To get started with bundling, simply add a @file{bundle.scm} file to
+the root of the project directory.  It could look something like this:
+
+@example
+'((asset-directories . ("images" "models"))
+  (bundle-name . "the-legend-of-emacs-1.0")
+  (code . "the-legend-of-emacs.scm")
+  (launcher-name . "the-legend-of-emacs"))
+@end example
+
+To create the bundle, simply run @command{chickadee bundle}.  Upon
+success, the file @file{the-legend-of-emacs-1.0.tar.gz} would be
+created in the current directory.
+
+To maximize the chances that the bundle will work on someone else's
+computer, it's best to build on the oldest supported Linux
+distribution available.  As of this writing, Ubuntu 18.04 LTS is a
+good choice.
+
+In addition to including system libraries and executables,
+@command{chickadee bundle} also includes the compiled Guile bytecode
+(the @file{.go} files) for all modules used by the game.  The module
+source files are @emph{not} included, so it's critical that all of the
+modules used by the game have been compiled.
+
+Available options:
+
+@itemize
+
+@item @code{asset-directories}
+
+A list of directories that hold static game assets such as images or
+audio.  Files in these directories will be copied into the bundle
+archive.
+
+@item @code{binary-directories}
+
+A list of directories to search for system binaries, such as
+@command{guile}.  By default, @file{/usr/bin} is searched.
+
+@item @code{bundle-name}
+
+The name of the bundle archive.  By default, the name is
+@code{"chickadee-bundle"}.
+
+@item @code{launcher-name}
+
+The name of the launcher script.  By default, the name is
+@code{"launch-game"}.
+
+@item @code{libraries}
+
+A list of shared libraries to include in the bundle.  By default, all
+of the libraries necessary for running Guile, Guile-SDL2, and
+Chickadee are included.  This list is compatible with the names given
+to the libraries on Ubuntu, which may be different than on other
+distributions.  In such cases, this list will need to be customized.
+See below for more information on the @code{%default-config} variable
+that can be of help.
+
+@item @code{library-directories}
+
+A list of directories to search for system shared libraries.  By
+default, the list contains common directories used by most
+distributions.
+
+@item @code{method}
+
+The method by which the game is launched.  Can be either @code{play}
+or @code{manual}.  The default is @code{play}, which means that
+@command{chickadee play} will be used to launch the game.  For games
+that do not use @command{chickadee play}, opting to start the game
+loop on their own, the @code{manual} method should be used.
+
+@item @code{play-args}
+
+A list of command line arguments to pass to @command{chickadee play}.
+Only used when the @code{method} option is set to @code{play}.
+
+@end itemize
+
+Default configuration options, such as the list of C shared libaries,
+can be found in the @code{%default-config} variable.  This way they
+can be programatically modified, if necessary.
+
+@defvar %default-config
+An association list of default configuration options.
+@end defvar
+
 @node Live Coding
 @chapter Live Coding
 
-- 
cgit v1.2.3