diff options
Diffstat (limited to 'nonguix/multiarch-container.scm')
-rw-r--r-- | nonguix/multiarch-container.scm | 613 |
1 files changed, 613 insertions, 0 deletions
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)))))))) |