nonguix: Remove unnecessary modules from multiarch-container scripts.

* nonguix/multiarch-container.scm (packages->ld.so.conf)[computed-file]: Remove
with-imported-modules and use-modules.
(make-container-wrapper)[program-file]: Remove with-imported-modules.

Signed-off-by: ison <ison@airmail.cc>
This commit is contained in:
Attila Lendvai 2023-05-29 20:16:11 -06:00 committed by ison
parent c7cb7dc6e5
commit 5bc3c9da84
No known key found for this signature in database
GPG Key ID: 5E76B1AD0FC22F93

View File

@ -6,6 +6,7 @@
;;; Copyright © 2021 Kozo <kozodev@runbox.com> ;;; Copyright © 2021 Kozo <kozodev@runbox.com>
;;; Copyright © 2021, 2022 John Kehayias <john.kehayias@protonmail.com> ;;; Copyright © 2021, 2022 John Kehayias <john.kehayias@protonmail.com>
;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> ;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
;;; Copyright © 2023 Attila Lendvai <attila@lendvai.name>
;;; The script provided by this package may optionally be started as ;;; The script provided by this package may optionally be started as
;;; a shell instead of automatically launching the wrapped entrypoint by setting ;;; a shell instead of automatically launching the wrapped entrypoint by setting
@ -161,30 +162,25 @@
in the Guix store" in the Guix store"
(computed-file (computed-file
"ld.so.conf" "ld.so.conf"
(with-imported-modules #~(begin
`((guix build union) ;; Need to quote "#$packages" as #$packages tries to "apply" the first item to the rest, like a procedure.
(guix build utils)) (let* ((packages '#$packages)
#~(begin ;; Add "/lib" to each package.
(use-modules (guix build union) ;; TODO Make this more general for other needed directories.
(guix build utils)) (dirs-lib
;; Need to quote "#$packages" as #$packages tries to "apply" the first item to the rest, like a procedure. (lambda (packages)
(let* ((packages '#$packages) (map (lambda (package)
;; Add "/lib" to each package. (string-append package "/lib"))
;; TODO Make this more general for other needed directories. packages)))
(dirs-lib (fhs-lib-dirs
(lambda (packages) (dirs-lib packages)))
(map (lambda (package) (call-with-output-file #$output
(string-append package "/lib")) (lambda (port)
packages))) (for-each (lambda (directory)
(fhs-lib-dirs (display directory port)
(dirs-lib packages))) (newline port))
(call-with-output-file #$output fhs-lib-dirs)))
(lambda (port) #$output))))
(for-each (lambda (directory)
(display directory port)
(newline port))
fhs-lib-dirs)))
#$output)))))
(define (nonguix-container->package container) (define (nonguix-container->package container)
"Return a package with wrapper script to launch the supplied container object "Return a package with wrapper script to launch the supplied container object
@ -250,112 +246,110 @@ in a sandboxed FHS environment."
in a sandboxed FHS environment." in a sandboxed FHS environment."
(program-file (program-file
(ngc-wrapper-name container) (ngc-wrapper-name container)
(with-imported-modules #~(begin
`((guix build utils)) (use-modules (guix build utils))
#~(begin (define (preserve-var var)
(use-modules (guix build utils)) (string-append "--preserve=" var))
(define (preserve-var var) (define* (add-path path #:key writable?)
(string-append "--preserve=" var)) (let ((opt (if writable?
(define* (add-path path #:key writable?) "--share="
(let ((opt (if writable? "--expose=")))
"--share=" (if (pair? path)
"--expose="))) (string-append opt (car path) "=" (cdr path))
(if (pair? path) (string-append opt path))))
(string-append opt (car path) "=" (cdr path)) (define (exists-> file)
(string-append opt path)))) (if (and file (file-exists? file))
(define (exists-> file) `(,file) '()))
(if (and file (file-exists? file)) (let* ((run #$(file-append fhs-internal "/bin/" (ngc-internal-name container)))
`(,file) '())) (manifest-file #$(file-append fhs-manifest))
(let* ((run #$(file-append fhs-internal "/bin/" (ngc-internal-name container))) (xdg-runtime (getenv "XDG_RUNTIME_DIR"))
(manifest-file #$(file-append fhs-manifest)) (home (getenv "HOME"))
(xdg-runtime (getenv "XDG_RUNTIME_DIR")) (sandbox-home (or (getenv "GUIX_SANDBOX_HOME")
(home (getenv "HOME")) (string-append home "/" #$(ngc-sandbox-home container))))
(sandbox-home (or (getenv "GUIX_SANDBOX_HOME") (preserved-env '("^DBUS_"
(string-append home "/" #$(ngc-sandbox-home container)))) "^DISPLAY$"
(preserved-env '("^DBUS_" "^DRI_PRIME$"
"^DISPLAY$" "^GDK_SCALE$" ; For UI scaling.
"^DRI_PRIME$" "^PRESSURE_VESSEL_" ; For pressure vessel options.
"^GDK_SCALE$" ; For UI scaling. "_PROXY$"
"^PRESSURE_VESSEL_" ; For pressure vessel options. "_proxy$"
"_PROXY$" "^SDL_"
"_proxy$" "^STEAM_"
"^SDL_" "^VDPAU_DRIVER_PATH$" ; For VDPAU drivers.
"^STEAM_" "^XAUTHORITY$"
"^VDPAU_DRIVER_PATH$" ; For VDPAU drivers. ;; Matching all ^XDG_ vars causes issues
"^XAUTHORITY$" ;; discussed in 80decf05.
;; Matching all ^XDG_ vars causes issues "^XDG_DATA_HOME$"
;; discussed in 80decf05. "^XDG_RUNTIME_DIR$"
"^XDG_DATA_HOME$" ;; The following are useful for debugging.
"^XDG_RUNTIME_DIR$" "^CAPSULE_DEBUG$"
;; The following are useful for debugging. "^G_MESSAGES_DEBUG$"
"^CAPSULE_DEBUG$" "^LD_DEBUG$"
"^G_MESSAGES_DEBUG$" "^LIBGL_DEBUG$"))
"^LD_DEBUG$" (expose `("/dev/bus/usb" ; Needed for libusb.
"^LIBGL_DEBUG$")) "/dev/dri"
(expose `("/dev/bus/usb" ; Needed for libusb. "/dev/input" ; Needed for controller input.
"/dev/dri" "/dev/uinput" ; Needed for Steam Input.
"/dev/input" ; Needed for controller input. ,@(exists-> "/dev/nvidia0") ; needed for nvidia proprietary driver
"/dev/uinput" ; Needed for Steam Input. ,@(exists-> "/dev/nvidiactl")
,@(exists-> "/dev/nvidia0") ; needed for nvidia proprietary driver ,@(exists-> "/dev/nvidia-modeset")
,@(exists-> "/dev/nvidiactl") ,@(exists-> "/etc/machine-id")
,@(exists-> "/dev/nvidia-modeset") "/etc/localtime" ; Needed for correct time zone.
,@(exists-> "/etc/machine-id") "/sys/class/drm" ; Needed for hw monitoring like MangoHud.
"/etc/localtime" ; Needed for correct time zone. "/sys/class/hwmon" ; Needed for hw monitoring like MangoHud.
"/sys/class/drm" ; Needed for hw monitoring like MangoHud. "/sys/class/hidraw" ; Needed for devices like the Valve Index.
"/sys/class/hwmon" ; Needed for hw monitoring like MangoHud. "/sys/class/input" ; Needed for controller input.
"/sys/class/hidraw" ; Needed for devices like the Valve Index. ,@(exists-> "/sys/class/power_supply") ; Needed for power monitoring like MangoHud.
"/sys/class/input" ; Needed for controller input. ,@(exists-> "/sys/class/powercap") ; Needed for power monitoring like MangoHud.
,@(exists-> "/sys/class/power_supply") ; Needed for power monitoring like MangoHud. "/sys/dev"
,@(exists-> "/sys/class/powercap") ; Needed for power monitoring like MangoHud. "/sys/devices"
"/sys/dev" ,@(exists-> "/var/run/dbus")))
"/sys/devices" ;; /dev/hidraw is needed for SteamVR to access the HMD, although here we
,@(exists-> "/var/run/dbus"))) ;; share all hidraw devices. Instead we could filter to only share specific
;; /dev/hidraw is needed for SteamVR to access the HMD, although here we ;; device. See, for example, this script:
;; share all hidraw devices. Instead we could filter to only share specific ;; https://arvchristos.github.io/post/matching-dev-hidraw-devices-with-physical-devices/
;; device. See, for example, this script: (share `(,@(find-files "/dev" "hidraw")
;; https://arvchristos.github.io/post/matching-dev-hidraw-devices-with-physical-devices/ "/dev/shm"
(share `(,@(find-files "/dev" "hidraw") ;; "/tmp/.X11-unix" is needed for bwrap, and "/tmp" more generally
"/dev/shm" ;; for writing things like crash dumps and "steam_chrome_shm".
;; "/tmp/.X11-unix" is needed for bwrap, and "/tmp" more generally "/tmp"
;; for writing things like crash dumps and "steam_chrome_shm". ,(string-append sandbox-home "=" home)
"/tmp" ,@(exists-> (string-append home "/.config/pulse"))
,(string-append sandbox-home "=" home) ,@(exists-> (string-append xdg-runtime "/pulse"))
,@(exists-> (string-append home "/.config/pulse")) ,@(exists-> (string-append xdg-runtime "/bus"))
,@(exists-> (string-append xdg-runtime "/pulse")) ,@(exists-> (getenv "XAUTHORITY"))))
,@(exists-> (string-append xdg-runtime "/bus")) (DEBUG (equal? (getenv "DEBUG") "1"))
,@(exists-> (getenv "XAUTHORITY")))) (args (cdr (command-line)))
(DEBUG (equal? (getenv "DEBUG") "1")) (command (if DEBUG '()
(args (cdr (command-line))) `("--" ,run ,@args))))
(command (if DEBUG '() ;; TODO: Remove once upstream change is merged and in stable pressure-vessel
`("--" ,run ,@args)))) ;; (although may want to hold off for anyone using older pressure-vessel versions
;; TODO: Remove once upstream change is merged and in stable pressure-vessel ;; for whatever reason), see:
;; (although may want to hold off for anyone using older pressure-vessel versions ;; https://gitlab.steamos.cloud/steamrt/steam-runtime-tools/-/merge_requests/406
;; for whatever reason), see: (setenv "PRESSURE_VESSEL_FILESYSTEMS_RO" "/gnu/store")
;; https://gitlab.steamos.cloud/steamrt/steam-runtime-tools/-/merge_requests/406 ;; By default VDPAU drivers are searched for in libvdpau's store
(setenv "PRESSURE_VESSEL_FILESYSTEMS_RO" "/gnu/store") ;; path, so set this path to where the drivers will actually be
;; By default VDPAU drivers are searched for in libvdpau's store ;; located in the container.
;; path, so set this path to where the drivers will actually be (setenv "VDPAU_DRIVER_PATH" "/lib64/vdpau")
;; located in the container. (format #t "\n* Launching ~a in sandbox: ~a.\n\n"
(setenv "VDPAU_DRIVER_PATH" "/lib64/vdpau") #$(package-name (ngc-wrap-package container)) sandbox-home)
(format #t "\n* Launching ~a in sandbox: ~a.\n\n" (when DEBUG
#$(package-name (ngc-wrap-package container)) sandbox-home) (format #t "* DEBUG set to 1: Starting shell. Launch application manually with: ~a.\n\n"
(when DEBUG #$(ngc-internal-name container)))
(format #t "* DEBUG set to 1: Starting shell. Launch application manually with: ~a.\n\n" (mkdir-p sandbox-home)
#$(ngc-internal-name container))) (invoke #$(file-append pulseaudio "/bin/pulseaudio")
(mkdir-p sandbox-home) "--start"
(invoke #$(file-append pulseaudio "/bin/pulseaudio") "--exit-idle-time=60")
"--start" (apply invoke
"--exit-idle-time=60") `("guix" "shell"
(apply invoke "--container" "--no-cwd" "--network"
`("guix" "shell" ,@(map preserve-var preserved-env)
"--container" "--no-cwd" "--network" ,@(map add-path expose)
,@(map preserve-var preserved-env) ,@(map (lambda (item)
,@(map add-path expose) (add-path item #:writable? #t))
,@(map (lambda (item) share)
(add-path item #:writable? #t)) "-m" ,manifest-file
share) ,@command))))))
"-m" ,manifest-file
,@command)))))))
(define (make-container-manifest container fhs-internal) (define (make-container-manifest container fhs-internal)
"Return a scheme file-like object to be used as package manifest for FHS "Return a scheme file-like object to be used as package manifest for FHS