path: root/chickadee/cli/bundle.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Chickadee 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.
;;;
;;; Chickadee 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 this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(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 (ice-9 regex)
  #: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 ignore-regexps)
  (define strip-source
    (let ((len (string-length source)))
      (lambda (file)
        (substring file len))))

  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (unless (any (lambda (regexp)
                                     (regexp-exec regexp file))
                                   ignore-regexps)
                        (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 ((go-dest (string-append destdir "/lib/guile/" v "/ccache/"
                                               (scm->go suffix))))
                   (mkdir-p (dirname go-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 ignore-regexps)
  (for-each (lambda (dir)
              (let ((target (string-append destdir "/" dir)))
                (copy-recursively dir target ignore-regexps)))
            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"
                  "freetype"
                  "gc"
                  "gmp"
                  "guile-3.0"
                  "turbojpeg"
                  "mpg123"
                  "ogg"
                  "openal"
                  "png16"
                  "readline"
                  "SDL2-2.0"
                  "sndfile"
                  "sndio"
                  "tinfo"
                  "unistring"
                  "vorbis"
                  "vorbisenc"
                  "vorbisfile"
                  "z"))
    (library-directories . ("/lib"
                            "/lib64"
                            "/lib/x86_64-linux-gnu"
                            "/usr/lib"
                            "/usr/lib/x86_64-linux-gnu"))
    (method . play)
    (play-args . ())
    (ignore-files . ())))

(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))
         (ignore-regexps (map make-regexp (assq-ref config 'ignore-files))))
    (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 ignore-regexps)
    (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 name))
      (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)
  (define (make-bundle* file-name)
    ;; Ensure file-name is an absolute file name.
    (let ((file-name (if (string-prefix? "/" file-name)
                         file-name
                         (string-append (getcwd) "/" file-name))))
      (add-to-load-path (dirname file-name))
      (set! %load-compiled-path (cons (dirname file-name) %load-compiled-path))
      (make-bundle (primitive-load file-name))))
  (let ((opts (simple-args-fold args %options %default-options)))
    (match (operands opts)
      (()
       (make-bundle* "bundle.scm"))
      ((file-name)
       (make-bundle* file-name))
      (_
       (leave "too many arguments specified. just pass a Scheme file name.")))))