diff options
Diffstat (limited to 'nonguix')
| -rw-r--r-- | nonguix/build-system/binary.scm | 17 | ||||
| -rw-r--r-- | nonguix/build-system/chromium-binary.scm | 209 | ||||
| -rw-r--r-- | nonguix/build/binary-build-system.scm | 51 | ||||
| -rw-r--r-- | nonguix/build/chromium-binary-build-system.scm | 74 | ||||
| -rw-r--r-- | nonguix/build/utils.scm | 22 | ||||
| -rw-r--r-- | nonguix/download.scm | 14 | ||||
| -rw-r--r-- | nonguix/licenses.scm | 14 | ||||
| -rw-r--r-- | nonguix/modules.scm | 14 | ||||
| -rw-r--r-- | nonguix/multiarch-container.scm | 613 | ||||
| -rw-r--r-- | nonguix/utils.scm | 18 |
10 files changed, 940 insertions, 106 deletions
diff --git a/nonguix/build-system/binary.scm b/nonguix/build-system/binary.scm index 4fed623..121162d 100644 --- a/nonguix/build-system/binary.scm +++ b/nonguix/build-system/binary.scm @@ -1,21 +1,6 @@ -;;; GNU Guix --- Functional package management for GNU +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2021 Josselin Poiret <dev@jpoiret.xyz> -;;; -;;; This file is not 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 (nonguix build-system binary) #:use-module (guix store) diff --git a/nonguix/build-system/chromium-binary.scm b/nonguix/build-system/chromium-binary.scm new file mode 100644 index 0000000..931a6ef --- /dev/null +++ b/nonguix/build-system/chromium-binary.scm @@ -0,0 +1,209 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> + +(define-module (nonguix build-system chromium-binary) + #:use-module (gnu packages bash) + #:use-module (gnu packages compression) + #:use-module (gnu packages cups) + #:use-module (gnu packages databases) + #:use-module (gnu packages fontutils) + #:use-module (gnu packages gcc) + #:use-module (gnu packages gl) + #:use-module (gnu packages glib) + #:use-module (gnu packages gnome) + #:use-module (gnu packages gtk) + #:use-module (gnu packages kerberos) + #:use-module (gnu packages linux) + #:use-module (gnu packages nss) + #:use-module (gnu packages pulseaudio) + #:use-module (gnu packages xdisorg) + #:use-module (gnu packages xorg) + #:use-module (gnu packages xml) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (nonguix build-system binary) + #:use-module (nonguix utils) + #:export (%chromium-binary-build-system-modules + lower + chromium-binary-build + chromium-binary-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Chromium based binary packages. This is +;; implemented as an extension of `binary-build-system'. +;; +;; Code: + +(define %chromium-binary-build-system-modules + ;; Build-side modules imported by default. + `((nonguix build chromium-binary-build-system) + (nonguix build utils) + ,@%binary-build-system-modules)) + +(define (build-patchelf-plan wrapper-plan inputs) + #~(let ((patchelf-inputs + (list #$@(map car inputs)))) + (map (lambda (file) + (cons file (list patchelf-inputs))) + #$wrapper-plan))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (patchelf (default-patchelf)) + (glibc (default-glibc)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:patchelf #:inputs #:native-inputs)) + (define host-inputs + `(,@(if source + `(("source" ,source)) + '()) + + ("alsa-lib" ,alsa-lib) + ("atk" ,atk) + ("at-spi2-atk" ,at-spi2-atk) + ("at-spi2-core" ,at-spi2-core) + ("bash-minimal" ,bash-minimal) + ("cairo" ,cairo) + ("cups" ,cups) + ("dbus" ,dbus) + ("eudev" ,eudev) + ("expat" ,expat) + ("fontconfig" ,fontconfig) + ("freetype" ,freetype) + ("gcc:lib" ,gcc "lib") + ("glib" ,glib) + ("gtk+" ,gtk+) + ("libdrm" ,libdrm) + ("libnotify" ,libnotify) + ("librsvg" ,librsvg) + ("libsecret" ,libsecret) + ("libx11" ,libx11) + ("libxcb" ,libxcb) + ("libxcomposite" ,libxcomposite) + ("libxcursor" ,libxcursor) + ("libxdamage" ,libxdamage) + ("libxext" ,libxext) + ("libxfixes" ,libxfixes) + ("libxi" ,libxi) + ("libxkbcommon" ,libxkbcommon) + ("libxkbfile" ,libxkbfile) + ("libxrandr" ,libxrandr) + ("libxrender" ,libxrender) + ("libxshmfence" ,libxshmfence) + ("libxtst" ,libxtst) + ("mesa" ,mesa) + ("mit-krb5" ,mit-krb5) + ("nspr" ,nspr) + ("nss" ,nss) + ("pango" ,pango) + ("pulseaudio" ,pulseaudio) + ("sqlcipher" ,sqlcipher) + ("xcb-util" ,xcb-util) + ("xcb-util-image" ,xcb-util-image) + ("xcb-util-keysyms" ,xcb-util-keysyms) + ("xcb-util-renderutil" ,xcb-util-renderutil) + ("xcb-util-wm" ,xcb-util-wm) + ("zlib" ,zlib) + + ,@inputs + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs host-inputs) + (build-inputs `(("patchelf" ,patchelf) + ,@native-inputs + ;; If current system is i686, the *32 packages will be the + ;; same as the non-32, but that's OK. + ("libc32" ,(to32 glibc)))) + (outputs outputs) + (build chromium-binary-build) + (arguments (append + (strip-keyword-arguments private-keywords arguments) + (list #:wrap-inputs host-inputs)))))) + +(define* (chromium-binary-build name inputs + #:key + guile source wrap-inputs + (outputs '("out")) + (wrapper-plan ''()) + (patchelf-plan ''()) + (install-plan ''(("." "./"))) + (search-paths '()) + (out-of-source? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (nonguix build chromium-binary-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules %chromium-binary-build-system-modules) + (modules '((nonguix build chromium-binary-build-system) + (guix build utils) + (nonguix build utils))) + (substitutable? #t) + allowed-references + disallowed-references) + "Build SOURCE using binary-build-system." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + + #$(with-build-variables inputs outputs + #~(chromium-binary-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:patchelf-plan + #$(if (equal? wrapper-plan ''()) + patchelf-plan + (build-patchelf-plan wrapper-plan + wrap-inputs)) + #:install-plan #$install-plan + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:out-of-source? #$out-of-source? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) + +(define chromium-binary-build-system + (build-system + (name 'chromium-binary) + (description "The Chromium based binary build system") + (lower lower))) + +;;; chromium-binary.scm ends here diff --git a/nonguix/build/binary-build-system.scm b/nonguix/build/binary-build-system.scm index 913ff44..e5bbc48 100644 --- a/nonguix/build/binary-build-system.scm +++ b/nonguix/build/binary-build-system.scm @@ -1,21 +1,7 @@ -;;; GNU Guix --- Functional package management for GNU +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2022 Attila Lendvai <attila@lendvai.name> -;;; -;;; This file is not 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/>. +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> (define-module (nonguix build binary-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) @@ -148,10 +134,39 @@ The inputs are optional when the file is an executable." patchelf-plan))) #t) +(define (deb-file? binary-file) + (string-suffix? ".deb" binary-file)) + +(define (unpack-deb deb-file) + (invoke "ar" "x" deb-file) + (invoke "tar" "xvf" "data.tar.xz") + (invoke "rm" "-rfv" "control.tar.gz" + "data.tar.xz" + deb-file + "debian-binary")) + +(define* (binary-unpack #:key source #:allow-other-keys) + (let* ((files (filter (lambda (f) + (not (string=? (basename f) "environment-variables"))) + (find-files (getcwd)))) + (binary-file (car files))) + (when (= 1 (length files)) + (mkdir "binary") + (chdir "binary") + (match binary-file + ((? deb-file?) (unpack-deb binary-file)) + (_ + (begin + (format #t "Unknown file type: ~a~%" (basename binary-file)) + ;; Cleanup after ourselves + (chdir "..") + (rmdir "binary"))))))) + (define %standard-phases - ;; Everything is as with the GNU Build System except for the `configure' - ;; , `build', `check' and `install' phases. + ;; Everything is as with the GNU Build System except for the `binary-unpack', + ;; `configure', `build', `check' and `install' phases. (modify-phases gnu:%standard-phases + (add-after 'unpack 'binary-unpack binary-unpack) (delete 'bootstrap) (delete 'configure) (delete 'build) diff --git a/nonguix/build/chromium-binary-build-system.scm b/nonguix/build/chromium-binary-build-system.scm new file mode 100644 index 0000000..8429742 --- /dev/null +++ b/nonguix/build/chromium-binary-build-system.scm @@ -0,0 +1,74 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> + +(define-module (nonguix build chromium-binary-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module ((nonguix build binary-build-system) #:prefix binary:) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:export (%standard-phases + chromium-binary-build)) + +;; Commentary: +;; +;; Builder-side code of the Chromium binary build procedure. +;; +;; Code: + +(define* (install-wrapper #:key inputs outputs #:allow-other-keys) + (let* ((output (assoc-ref outputs "out")) + (bin (string-append output "/bin")) + (fontconfig-minimal (assoc-ref inputs "fontconfig")) + (nss (assoc-ref inputs "nss")) + (wrap-inputs (map cdr inputs)) + (lib-directories + (search-path-as-list '("lib") wrap-inputs)) + (bin-directories + (search-path-as-list + '("bin" "sbin" "libexec") + wrap-inputs))) + (for-each + (lambda (exe) + (display (string-append "Wrapping " exe "\n")) + (wrap-program exe + `("FONTCONFIG_PATH" ":" prefix + (,(string-join + (list + (string-append fontconfig-minimal "/etc/fonts") + output) + ":"))) + `("PATH" ":" prefix + (,(string-join + (append + bin-directories + (list + bin)) + ":"))) + `("LD_LIBRARY_PATH" ":" prefix + (,(string-join + (append + lib-directories + (list + (string-append nss "/lib/nss") + output)) + ":"))))) + (map + (lambda (exe) (string-append bin "/" exe)) + (filter + (lambda (exe) (not (string-prefix? "." exe))) + (scandir bin)))) + #t)) + +(define %standard-phases + ;; Everything is as with the binary-build-system except for the + ;; `install-wrapper' phase. + (modify-phases binary:%standard-phases + (add-after 'install 'install-wrapper install-wrapper))) + +(define* (chromium-binary-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; chromium-binary-build-system.scm ends here diff --git a/nonguix/build/utils.scm b/nonguix/build/utils.scm index ab437f2..4de2ac2 100644 --- a/nonguix/build/utils.scm +++ b/nonguix/build/utils.scm @@ -1,30 +1,18 @@ -;;; GNU Guix --- Functional package management for GNU +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> ;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> -;;; -;;; This file is not 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/>. +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> (define-module (nonguix build utils) #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:use-module (guix build utils) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (64-bit? make-wrapper - concatenate-files)) + concatenate-files + build-paths-from-inputs)) (define (64-bit? file) "Return true if ELF file is in 64-bit format, false otherwise. diff --git a/nonguix/download.scm b/nonguix/download.scm index 11087ff..0eb661a 100644 --- a/nonguix/download.scm +++ b/nonguix/download.scm @@ -1,17 +1,5 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> -;;; -;;; This program 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. -;;; -;;; This program 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 <https://www.gnu.org/licenses/>. (define-module (nonguix download) #:use-module (guix derivations) diff --git a/nonguix/licenses.scm b/nonguix/licenses.scm index 84d2346..a09452a 100644 --- a/nonguix/licenses.scm +++ b/nonguix/licenses.scm @@ -1,17 +1,5 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Alex Griffin <a@ajgrf.com> -;;; -;;; This program 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. -;;; -;;; This program 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 <https://www.gnu.org/licenses/>. (define-module (nonguix licenses) #:use-module (guix licenses) diff --git a/nonguix/modules.scm b/nonguix/modules.scm index 24d4267..cd07d44 100644 --- a/nonguix/modules.scm +++ b/nonguix/modules.scm @@ -1,17 +1,5 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> -;;; -;;; This program 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. -;;; -;;; This program 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 <https://www.gnu.org/licenses/>. (define-module (nonguix modules) #:use-module (ice-9 match) diff --git a/nonguix/multiarch-container.scm b/nonguix/multiarch-container.scm new file mode 100644 index 0000000..a6f62fc --- /dev/null +++ b/nonguix/multiarch-container.scm @@ -0,0 +1,613 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later +;;; Copyright © 2020 pkill-9 +;;; Copyright © 2020, 2021 ison <ison@airmail.cc> +;;; Copyright © 2021 pineapples +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021 Kozo <kozodev@runbox.com> +;;; Copyright © 2021, 2022 John Kehayias <john.kehayias@protonmail.com> +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> +;;; Copyright © 2023 Attila Lendvai <attila@lendvai.name> +;;; Copyright © 2023 Elijah Malaby +;;; Copyright © 2023 Timo Wilken <guix@twilken.net> + +;;; The script provided by this package may optionally be started as +;;; a shell instead of automatically launching the wrapped entrypoint by setting +;;; the environment variable DEBUG=1. If the sandbox is started this way then +;;; the package should subsequently be launched via fhs-internal. + +;;; The sandbox shell aids in debugging missing container elements. For +;;; example a missing symlink may be created manually before launching the +;;; package to verify that the fix works before filing a bug report. + +;;; A container wrapper creates the following store items: +;;; * Main container package [nonguix-container->package] (basically a dummy +;;; package with symlink to wrapper script) +;;; - Wrapper script [make-container-wrapper] (runs "guix shell") +;;; References: +;;; -> manifest.scm [make-container-manifest] (used by wrapper to guarantee +;;; exact store items) +;;; -> container-internal [make-container-internal] {inside container} +;;; (dummy package added to container with symlink to internal-script) +;;; - internal-script [make-internal-script] {inside container} +;;; (script run in-container which performs additional setup before +;;; launching the desired application) +;;; References: +;;; -> Wrapped package {inside container}. + +;;; Note: The extra container-internal package is necessary because there is no +;;; way to add the container package's own store path to its own manifest unless +;;; the manifest is printed inside the build phases. However, the (guix gexp) +;;; module is apparently disallowed inside build phases. + +(define-module (nonguix multiarch-container) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages pulseaudio) + #:use-module (guix build-system trivial) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (guix packages) + + #:export (nonguix-container + nonguix-container? + ngc-name + ngc-binary-name + ngc-version + ngc-wrap-package + ngc-run + ngc-wrapper-name + ngc-manifest-name + ngc-internal-name + ngc-sandbox-home + ngc-ld.so.conf + ngc-ld.so.cache + ngc-union64 + ngc-union32 + ngc-preserved-env + ngc-exposed + ngc-shared + ngc-modules + ngc-packages + ngc-link-files + ngc-home-page + ngc-synopsis + ngc-description + ngc-license + + fhs-min-libs + fhs-union + ld.so.conf->ld.so.cache + packages->ld.so.conf + nonguix-container->package)) + +(define-record-type* <nonguix-container> + nonguix-container make-nonguix-container + nonguix-container? this-nonguix-container + (name ngc-name) + (binary-name ngc-binary-name (default (ngc-name this-nonguix-container)) (thunked)) + (version ngc-version (default #f)) + (wrap-package ngc-wrap-package) + (run ngc-run) + (wrapper-name ngc-wrapper-name (default "nonguix-container-wrapper")) + (manifest-name ngc-manifest-name (default "nonguix-container-manifest.scm")) + (internal-name ngc-internal-name (default "fhs-internal")) + (sandbox-home ngc-sandbox-home (default ".local/share/guix-sandbox-home")) + (ld.so.conf ngc-ld.so.conf) + (ld.so.cache ngc-ld.so.cache) + (union64 ngc-union64 (default '())) + (union32 ngc-union32 (default '())) + (preserved-env ngc-preserved-env (default '())) + (exposed ngc-exposed (default '())) + (shared ngc-shared (default '())) + (modules ngc-modules (default '())) + (packages ngc-packages (default '())) + (link-files ngc-link-files (default '())) + (home-page ngc-home-page (default #f)) + (synopsis ngc-synopsis (default #f)) + (description ngc-description (default #f)) + (license ngc-license (default #f))) + +(define fhs-min-libs + `(("glibc" ,(@@ (gnu packages base) glibc-for-fhs)) + ("glibc-locales" ,glibc-locales))) + +(define* (fhs-union inputs #:key (name "fhs-union") (version "0.0") (system "x86_64-linux")) + "Create a package housing the union of inputs." + (package + (name name) + (version version) + (source #f) + (inputs inputs) + (build-system trivial-build-system) + (arguments + `(#:system ,system + #:modules ((guix build union)) + #:builder + (begin + (use-modules (ice-9 match) + (guix build union)) + (match %build-inputs + (((_ . directories) ...) + (union-build (assoc-ref %outputs "out") + directories) + #t))))) + (home-page #f) + (synopsis "Libraries used for FHS") + (description "Libraries needed to build a guix container FHS.") + (license #f))) + +(define (ld.so.conf->ld.so.cache ld-conf) + "Create a ld.so.cache file-like object from an ld.so.conf file." + (computed-file + "ld.so.cache" + (with-imported-modules + `((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (let ((ldconfig (string-append #$glibc "/sbin/ldconfig"))) + (invoke ldconfig + "-X" ; Don't update symbolic links. + "-f" #$ld-conf ; Use #$ld-conf as configuration file. + "-C" #$output)))))) ; Use #$output as cache file. + +(define (packages->ld.so.conf packages) + "Takes a list of package objects and returns a file-like object for ld.so.conf +in the Guix store" + (computed-file + "ld.so.conf" + #~(begin + ;; Need to quote "#$packages" as #$packages tries to "apply" the first item to the rest, like a procedure. + (let* ((packages '#$packages) + ;; Add "/lib" to each package. + ;; TODO Make this more general for other needed directories. + (dirs-lib + (lambda (packages) + (map (lambda (package) + (string-append package "/lib")) + packages))) + (fhs-lib-dirs + (dirs-lib packages))) + (call-with-output-file #$output + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + fhs-lib-dirs))) + #$output)))) + +(define (nonguix-container->package container) + "Return a package with wrapper script to launch the supplied container object +in a sandboxed FHS environment." + (let* ((fhs-internal (make-container-internal container)) + (fhs-manifest (make-container-manifest container fhs-internal)) + (fhs-wrapper (make-container-wrapper container fhs-manifest fhs-internal)) + (pkg (ngc-wrap-package container))) + (package + (name (ngc-name container)) + (version (or (ngc-version container) + (package-version pkg))) + (source #f) + (inputs `(("wrap-package" ,(ngc-wrap-package container)) + ,@(if (null? (ngc-union64 container)) + '() + `(("fhs-union-64" ,(ngc-union64 container)))) + ,@(if (null? (ngc-union32 container)) + '() + `(("fhs-union-32" ,(ngc-union32 container)))) + ("fhs-internal" ,fhs-internal) + ("fhs-wrapper" ,fhs-wrapper) + ("fhs-manifest" ,fhs-manifest))) + (build-system trivial-build-system) + (arguments + `(#:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((out (assoc-ref %outputs "out")) + (internal-target (string-append (assoc-ref %build-inputs "fhs-internal") + "/bin/" ,(ngc-internal-name container))) + (internal-dest (string-append out "/sbin/" ,(ngc-internal-name container))) + (manifest-target (assoc-ref %build-inputs "fhs-manifest")) + (manifest-dest (string-append out "/etc/" ,(ngc-manifest-name container))) + (wrapper-target (assoc-ref %build-inputs "fhs-wrapper")) + (wrapper-dest (string-append out "/bin/" ,(ngc-binary-name container))) + (link-files ',(ngc-link-files container))) + (mkdir-p (string-append out "/sbin")) + (mkdir-p (string-append out "/etc")) + (mkdir-p (string-append out "/bin")) + (symlink internal-target internal-dest) + (symlink wrapper-target wrapper-dest) + (symlink manifest-target manifest-dest) + (for-each + (lambda (link) + (mkdir-p (dirname (string-append out "/" link))) + (symlink (string-append (assoc-ref %build-inputs "wrap-package") + "/" link) + (string-append out "/" link))) + link-files))))) + (home-page (or (ngc-home-page container) + (package-home-page pkg))) + (synopsis (or (ngc-synopsis container) + (package-synopsis pkg))) + (description (or (ngc-description container) + (package-description pkg))) + (license (or (ngc-license container) + (package-license pkg)))))) + +(define (make-container-wrapper container fhs-manifest fhs-internal) + "Return a script file-like object that launches the supplied container object +in a sandboxed FHS environment." + (program-file + (ngc-wrapper-name container) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (define (preserve-var var) + (string-append "--preserve=" var)) + (define* (add-path path #:key writable?) + (let ((opt (if writable? + "--share=" + "--expose="))) + (if (pair? path) + (string-append opt (car path) "=" (cdr path)) + (string-append opt path)))) + (define (exists-> file) + (if (and file (file-exists? file)) + `(,file) '())) + (let* ((run #$(file-append fhs-internal "/bin/" (ngc-internal-name container))) + (manifest-file #$(file-append fhs-manifest)) + (xdg-runtime (getenv "XDG_RUNTIME_DIR")) + (home (getenv "HOME")) + (sandbox-home (or (getenv "GUIX_SANDBOX_HOME") + (string-append home "/" #$(ngc-sandbox-home container)))) + (wayland-display (or (getenv "WAYLAND_DISPLAY") + "wayland-0")) + (preserved-env '("^DBUS_" + "^DRI_PRIME$" + "^GDK_SCALE$" ; For UI scaling. + "^GUIX_LOCPATH$" ; For pressure-vessel locales. + ;; For startup of added non-Steam games as it + ;; seems they start in an early environment + ;; before our additional settings. (Likely + ;; this can be removed when rewritten to use + ;; --emulate-fhs from upstream.) Note that + ;; this is explicitly set below. We could + ;; preserve what is set before launching the + ;; container, but any such directories would + ;; need to be shared with the container as + ;; well; this is not needed currently. + "^LD_LIBRARY_PATH$" + "^LIBVA_DRIVERS_PATH$" ; For VA-API drivers. + "^MANGOHUD" ; For MangoHud configuration. + "^PRESSURE_VESSEL_" ; For pressure vessel options. + "_PROXY$" + "_proxy$" + ;; To allow workaround for upstream bug + ;; <https://github.com/ValveSoftware/steam-for-linux/issues/9306> + ;; and tracked on our end as + ;; <https://gitlab.com/nonguix/nonguix/-/issues/267>. + ;; TODO: Remove once upstream fixes this bug. + "^QT_X11_NO_MITSHM$" + "^SDL_" + "^STEAM_" + "^SSL_" ; SSL certificate environment, needed by curl for Heroic. + "^TZ" ; For setting time zone. + "^XAUTHORITY$" + ;; Matching all ^XDG_ vars causes issues + ;; discussed in 80decf05. + "^XDG_CURRENT_DESKTOP$" + "^XDG_DATA_HOME$" + "^XDG_RUNTIME_DIR$" + "^XDG_SESSION_(CLASS|TYPE)$" + "^(WAYLAND_)?DISPLAY$" + #$@(ngc-preserved-env container) ; Environment from container. + ;; The following are useful for debugging. + "^CAPSULE_DEBUG$" + "^G_MESSAGES_DEBUG$" + "^LD_DEBUG$" + "^LIBGL_DEBUG$")) + (expose `("/dev/bus/usb" ; Needed for libusb. + "/dev/dri" + "/dev/input" ; Needed for controller input. + "/dev/uinput" ; Needed for Steam Input. + ,@(exists-> "/dev/nvidia0") ; needed for nvidia proprietary driver + ,@(exists-> "/dev/nvidiactl") + ,@(exists-> "/dev/nvidia-modeset") + ,@(exists-> "/etc/machine-id") + "/etc/localtime" ; Needed for correct time zone. + "/etc/os-release" ; Needed for distro info. + "/sys/class/drm" ; Needed for hw monitoring like MangoHud. + "/sys/class/hwmon" ; Needed for hw monitoring like MangoHud. + "/sys/class/hidraw" ; Needed for devices like the Valve Index. + "/sys/class/input" ; Needed for controller input. + ,@(exists-> "/sys/class/power_supply") ; Needed for power monitoring like MangoHud. + ,@(exists-> "/sys/class/powercap") ; Needed for power monitoring like MangoHud. + "/sys/dev" + "/sys/devices" + ,@(exists-> "/var/run/dbus") + #$@(ngc-exposed container))) + ;; /dev/hidraw is needed for SteamVR to access the HMD, although here we + ;; share all hidraw devices. Instead we could filter to only share specific + ;; device. See, for example, this script: + ;; https://arvchristos.github.io/post/matching-dev-hidraw-devices-with-physical-devices/ + (share `(,@(find-files "/dev" "hidraw") + "/dev/shm" + ;; "/tmp/.X11-unix" is needed for bwrap, and "/tmp" more generally + ;; for writing things like crash dumps and "steam_chrome_shm". + "/tmp" + ,(string-append sandbox-home "=" home) + ,@(exists-> (string-append home "/.config/pulse")) + ,@(exists-> (string-append xdg-runtime "/pulse")) + ,@(exists-> (string-append xdg-runtime "/bus")) + ,@(exists-> (string-append xdg-runtime "/" wayland-display)) + ,@(exists-> (getenv "XAUTHORITY")) + #$@(ngc-shared container))) + (DEBUG (equal? (getenv "DEBUG") "1")) + (extra-shares (if (getenv "GUIX_SANDBOX_EXTRA_SHARES") + (string-split (getenv "GUIX_SANDBOX_EXTRA_SHARES") #\:) + #f)) + (args (cdr (command-line))) + (command (if DEBUG '() + `("--" ,run ,@args)))) + ;; Set this so Steam's pressure-vessel container does not need to + ;; generate locales, improving startup time. This needs to be set to + ;; the "usual" path, probably so they are included in the + ;; pressure-vessel container. + (setenv "GUIX_LOCPATH" "/usr/lib/locale") + ;; By default VA-API drivers are searched for in mesa's store path, + ;; so set this path to where the drivers will actually be located in + ;; the container. + (setenv "LIBVA_DRIVERS_PATH" "/lib64/dri:/lib/dri") + (format #t "\n* Launching ~a in sandbox: ~a.\n\n" + #$(package-name (ngc-wrap-package container)) sandbox-home) + (when DEBUG + (format #t "* DEBUG set to 1: Starting shell. Launch application manually with: ~a.\n\n" + #$(ngc-internal-name container))) + (mkdir-p sandbox-home) + (invoke #$(file-append pulseaudio "/bin/pulseaudio") + "--start" + "--exit-idle-time=60") + (apply invoke + `("guix" "shell" + "--container" "--no-cwd" "--network" + ,@(map preserve-var preserved-env) + ,@(map add-path expose) + ,@(map (lambda (item) + (add-path item #:writable? #t)) + (if extra-shares + (append share extra-shares) + share)) + "-m" ,manifest-file + ,@command))))))) + +(define (make-container-manifest container fhs-internal) + "Return a scheme file-like object to be used as package manifest for FHS +containers. This manifest will use the 'modules' and 'packages' fields +specified in the container object, and will also include the exact store paths +of the containers 'wrap-package', 'union32', and 'union64' fields, as well as +the exact path for the fhs-internal package." + (scheme-file + (ngc-manifest-name container) + #~(begin + (use-package-modules + #$@(ngc-modules container)) + (use-modules (guix gexp) + (guix utils) + (guix profiles) + (guix store) + (guix scripts package) + (srfi srfi-11)) + + ;; Copied from guix/scripts/package.scm. + (define (store-item->manifest-entry item) + "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." + (let-values (((name version) + (package-name->name+version (store-path-package-name item) + #\-))) + (manifest-entry + (name name) + (version version) + (output "out") ;XXX: wild guess + (item item)))) + + (manifest-add + (packages->manifest (list #$@(ngc-packages container))) + (map store-item->manifest-entry + '(#$(file-append (ngc-wrap-package container)) + #$(file-append (ngc-union64 container)) + #$(file-append (ngc-union32 container)) + #$(file-append fhs-internal))))))) + +(define (make-container-internal container) + "Return a dummy package housing the fhs-internal script." + (package + (name (ngc-internal-name container)) + (version (or (ngc-version container) + (package-version (ngc-wrap-package container)))) + (source #f) + (inputs `(("fhs-internal-script" + ,(make-internal-script container)))) + (build-system trivial-build-system) + (arguments + `(#:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((bin (string-append (assoc-ref %outputs "out") "/bin")) + (internal-target (assoc-ref %build-inputs "fhs-internal-script")) + (internal-dest (string-append bin "/" ,(ngc-internal-name container)))) + (mkdir-p bin) + (symlink internal-target internal-dest))))) + (home-page #f) + (synopsis "Script used to set up sandbox") + (description "Script used inside the FHS Guix container to set up the +environment.") + (license #f))) + +(define (make-internal-script container) + "Return an fhs-internal script which is used to perform additional steps to +set up the environment inside an FHS container before launching the desired +application." + ;; The ld cache is not created inside the container, meaning the paths it + ;; contains are directly to /gnu/store/. Instead, it could be generated with + ;; a generic ld.so.conf and result in paths more typical in an FHS distro, + ;; like /lib within the container. This may be useful for future compatibility. + (let* ((ld.so.conf (ngc-ld.so.conf container)) + (ld.so.cache (ngc-ld.so.cache container)) + (pkg (ngc-wrap-package container)) + (run (ngc-run container))) + (program-file + (ngc-internal-name container) + (with-imported-modules + `((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 getopt-long) + (srfi srfi-1) + (srfi srfi-26)) + (define (path->str path) + (if (list? path) + (string-join path "/") + path)) + (define (new-symlink pair) + (let ((target (path->str (car pair))) + (dest (path->str (cdr pair)))) + (unless (file-exists? dest) + (symlink target dest)))) + (define (file-symlink file dir) + (mkdir-p dir) + (new-symlink + `(,file . (,dir ,(basename file))))) + ;; Use stat to follow links from packages like MangoHud. + (define (get-files dir) + (find-files (path->str dir) #:stat stat)) + (define fhs-option-spec + '((asound32 (value #f)))) + (let* ((guix-env (getenv "GUIX_ENVIRONMENT")) + (union64 #$(file-append (ngc-union64 container))) + (union32 #$(file-append (ngc-union32 container))) + (ld.so.conf #$(file-append ld.so.conf)) + (ld.so.cache #$(file-append ld.so.cache)) + (all-args (cdr (command-line))) + (fhs-args (member "--" all-args)) + (package-args (if fhs-args + (reverse (cdr (member "--" (reverse all-args)))) + all-args))) + (delete-file "/bin/sh") + (rmdir "/bin") + (for-each + mkdir-p + '("/run/current-system/profile/etc" + "/run/current-system/profile/share" + "/sbin" + "/usr/lib" + "/usr/share")) + (for-each + new-symlink + `((,ld.so.cache . "/etc/ld.so.cache") + (,ld.so.conf . "/etc/ld.so.conf") ;; needed? + ((,guix-env "etc/ssl") . "/etc/ssl") + ((,guix-env "etc/ssl") . "/run/current-system/profile/etc/ssl") + ((,union32 "lib") . "/lib") + ((,union32 "lib") . "/run/current-system/profile/lib") + ((,union64 "bin") . "/bin") + ((,union64 "bin") . "/usr/bin") ; Steam hardcodes some paths like xdg-open. + ((,union64 "lib") . "/lib64") + ((,union64 "lib") . "/run/current-system/profile/lib64") + ((,union64 "lib/locale") . "/run/current-system/locale") + ;; Despite using GUIX_LOCPATH, stil need locales in their + ;; expected location for pressure-vessel to use them. + ((,union64 "lib/locale") . "/usr/lib/locale") + ((,union64 "sbin/ldconfig") . "/sbin/ldconfig") + ((,union64 "share/mime") . "/usr/share/mime") ; Steam tray icon. + ((,union64 "share/glib-2.0") . "/usr/share/glib-2.0") ; Heroic interface. + ((,union64 "share/drirc.d") . "/usr/share/drirc.d") + ((,union64 "share/fonts") . "/usr/share/fonts") + ((,union64 "share/fonts") . "/run/current-system/profile/share/fonts") + ((,union64 "etc/fonts") . "/etc/fonts"))) + (for-each + (cut file-symlink <> "/usr/share/egl/egl_external_platform.d") + (append-map + get-files + `((,union32 "share/egl/egl_external_platform.d") + (,union64 "share/egl/egl_external_platform.d")))) + (for-each + (cut file-symlink <> "/usr/share/glvnd/egl_vendor.d") + (append-map + get-files + `((,union32 "share/glvnd/egl_vendor.d") + (,union64 "share/glvnd/egl_vendor.d")))) + (for-each + (cut file-symlink <> "/usr/share/vulkan/icd.d") + (append-map + get-files + `((,union32 "share/vulkan/icd.d") + (,union64 "share/vulkan/icd.d")))) + (for-each + (cut file-symlink <> "/usr/share/vulkan/explicit_layer.d") + (append-map + get-files + `((,union64 "share/vulkan/explicit_layer.d") + (,union32 "share/vulkan/explicit_layer.d")))) + (for-each + (cut file-symlink <> "/usr/share/vulkan/implicit_layer.d") + (append-map + get-files + `((,union32 "share/vulkan/implicit_layer.d") + (,union64 "share/vulkan/implicit_layer.d") + ;; For MangoHud implicit layers. + (,guix-env "share/vulkan/implicit_layer.d")))) + ;; TODO: This is not the right place for this. + ;; Newer versions of Steam won't startup if they can't copy to here + ;; (previous would output this error but continue). + (if (file-exists? ".steam/root/bootstrap.tar.xz") + (chmod ".steam/root/bootstrap.tar.xz" #o644)) + ;; TODO: Should other environment setup also happen inside the + ;; container rather than before container is launched? + ;; + ;; Set this so that e.g. non-Steam games added to Steam will + ;; launch properly. It seems otherwise they don't make it to + ;; launching Steam's pressure-vessel container (for Proton + ;; games). Wait to set this inside the container to not cause + ;; issues on foreign distros, see + ;; <https://gitlab.com/nonguix/nonguix/-/issues/303> + (setenv "LD_LIBRARY_PATH" "/lib64:/lib:/lib64/vdpau:/lib/vdpau") + + ;; Process FHS-specific command line options. + (let* ((options (getopt-long (or fhs-args '("")) fhs-option-spec)) + (asound32-opt (option-ref options 'asound32 #f)) + (asound-lib (if asound32-opt "lib" "lib64"))) + (if asound32-opt + (display "\n\n/etc/asound.conf configured for 32-bit.\n\n\n") + (display (string-append "\n\n/etc/asound.conf configured for 64-bit.\nLaunch " + #$(ngc-binary-name container) + " with \"" + (basename #$(ngc-run container)) + " -- --asound32\" to use 32-bit instead.\n\n\n"))) + (with-output-to-file "/etc/asound.conf" + (lambda _ (format (current-output-port) "# Generated by nonguix's internal script + +# Use PulseAudio by default +pcm_type.pulse { + lib \"/~a/alsa-lib/libasound_module_pcm_pulse.so\" +} + +ctl_type.pulse { + lib \"/~a/alsa-lib/libasound_module_ctl_pulse.so\" +} + +pcm.!default { + type pulse + fallback \"sysdefault\" + hint { + show on + description \"Default ALSA Output (currently PulseAudio Sound Server)\" + } +} + +ctl.!default { + type pulse + fallback \"sysdefault\" +}\n\n" asound-lib asound-lib)))) + + (apply system* `(#$(file-append pkg run) ,@package-args)))))))) diff --git a/nonguix/utils.scm b/nonguix/utils.scm index 7611a47..6703f4a 100644 --- a/nonguix/utils.scm +++ b/nonguix/utils.scm @@ -1,20 +1,6 @@ -;;; GNU Guix --- Functional package management for GNU +;;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; -;;; This file is not 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/>. +;;; Copyright © 2020 Jonathan Brielmaier <jonathan.brielmaier@web.de> (define-module (nonguix utils) #:use-module (srfi srfi-26) |