Lispln/nonguix
1
0
Fork 0
mirror of https://gitlab.com/nonguix/nonguix.git synced 2024-11-23 00:48:08 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
nonguix/nongnu/packages/steam-client.scm
ison 93c656566b
nongnu: steam: Use guile instead of bash for scripts. 
* nongnu/packages/steam-client.scm: Use module guix records.
  (<nonguix-container>): New record type.
  (glibc-for-fhs-32, steam-libs-32, steam-libs-64): Removed.
  (packages->ld.so.conf): Rename to fhs-ld.so.conf and use static paths.
  (steam): Rename to steam-client, remove wrappers and inputs, and
  replace with new definition for steam.
  (fhs-min-libs): New alist.
  (steam-client-libs): Add bash and coreutils, remove glibc and glibc-32.
  (steam-gameruntime-libs): Add font-dejavu and font-liberation.
  (fhs-union, nonguix-container->package, make-container-wrapper)
  (make-container-manifest, make-container-internal)
  (make-internal-script): New functions.
2020-09-15 13:37:52 +02:00

582 lines
22 KiB
Scheme
Raw Blame History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 pkill-9, ison <ison@airmail.cc>
;;;
;;; 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/>.
;;; The steam script provided by this package may optionally be started as
;;; a shell instead of automatically launching Steam by setting the
;;; environment variable DEBUG=1. If the sandbox is started this way then
;;; Steam should subsequently be launched via fhs-internal-script.
;;; The sandbox shell aids in debugging missing container elements. For
;;; example a missing symlink may be created manually before launching Steam
;;; to verify that the fix works before filing a bug report.
(define-module (nongnu packages steam-client)
#:use-module ((nonguix licenses) #:prefix license:)
#:use-module (gnu packages)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix utils)
#:use-module (guix download)
#:use-module (guix build utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (gnu packages audio)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages compression)
#:use-module (gnu packages cups)
#:use-module (gnu packages curl)
#:use-module (gnu packages fonts)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages gcc)
#:use-module (gnu packages gl)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gstreamer)
#:use-module (gnu packages gtk)
#:use-module (gnu packages image)
#:use-module (gnu packages libcanberra)
#:use-module (gnu packages libffi)
#:use-module (gnu packages libidn)
#:use-module (gnu packages libusb)
#:use-module (gnu packages linux)
#:use-module (gnu packages nss)
#:use-module (gnu packages pcre)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages sdl)
#:use-module (gnu packages selinux)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tbb)
#:use-module (gnu packages tls)
#:use-module (gnu packages video)
#:use-module (gnu packages vulkan)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages xiph)
#:use-module (gnu packages xml)
#:use-module (gnu packages xorg)
#:use-module (srfi srfi-1))
(define-record-type* <nonguix-container>
nonguix-container make-nonguix-container
nonguix-container? this-nonguix-container
(name ngc-name)
(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"))
(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 '()))
(home-page ngc-home-page (default #f))
(synopsis ngc-synopsis (default #f))
(description ngc-description (default #f))
(license ngc-license (default #f)))
(define glibc-for-fhs
(package
(inherit glibc)
(name "glibc-for-fhs")
(source (origin
(inherit (package-source glibc))
(snippet #f))))) ; Re-enable ldconfig.
(define libgcrypt-1.5.4 ; Half-Life needs libgcrypt.so.11.
(package
(inherit libgcrypt)
(version "1.5.4")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
version ".tar.bz2"))
(sha256
(base32
"0czvqxkzd5y872ipy6s010ifwdwv29sqbnqc4pf56sd486gqvy6m"))))))
(define libffi-3.2
(package
(inherit libffi)
(version "3.2")
(source (origin
(method url-fetch)
(uri
(string-append "ftp://sourceware.org/pub/libffi/"
(package-name libffi) "-" version ".tar.gz"))
(sha256
(base32
"1vylvsrbzrpqk298i4g1p82jxqkxhl2qf941sf0j775fyvxq09kb"))))))
(define steam-client
(package
(name "steam-client")
(version "1.0.0.61")
(source
(origin
(method url-fetch)
(uri (string-append "http://repo.steampowered.com/steam/archive/precise/steam_"
version ".tar.gz"))
(sha256
(base32
"0c5xy57gwr14vp3wy3jpqi5dl6y7n01p2dy4jlgl9bf9x7616r6n"))
(file-name (string-append name "-" version ".tar.gz"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f
#:make-flags
(list "PREFIX=" (string-append "DESTDIR=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-after 'unpack 'patch-startscript
(lambda _
(substitute* "steam"
(("/usr") (assoc-ref %outputs "out")))
#t))
(add-after 'unpack 'patch-desktop-file
(lambda _
(substitute* "steam.desktop"
(("Exec=/usr/bin/steam") "Exec=steam"))
#t))
;; Steamdeps installs missing packages, which doesn't work with Guix.
(add-after 'install-binaries 'remove-unneccessary-file
(lambda _
(delete-file (string-append (assoc-ref %outputs "out")
"/bin/steamdeps"))
#t)))))
(home-page "https://store.steampowered.com")
(synopsis "Digital distribution platform for managing and playing games")
(description "Steam is a digital software distribution platform created by Valve.")
(license (license:nonfree "file:///share/doc/steam/steam_subscriber_agreement.txt"))))
(define fhs-min-libs
`(("glibc-for-fhs" ,glibc-for-fhs)
("glibc-locales" ,glibc-locales)))
(define steam-client-libs
`(("alsa-lib" ,alsa-lib)
("alsa-plugins:pulseaudio" ,alsa-plugins "pulseaudio")
("at-spi2-atk" ,at-spi2-atk) ; Required by steam client beta.
("at-spi2-core" ,at-spi2-core) ; Required by steam client beta.
("atk" ,atk)
("bash" ,bash)
("bzip2" ,bzip2)
("cairo" ,cairo)
("coreutils" ,coreutils)
("cups" ,cups)
("curl" ,curl)
("dbus" ,dbus)
("dbus-glib" ,dbus-glib)
("eudev" ,eudev)
("expat" ,expat)
("fontconfig" ,fontconfig)
("freetype" ,freetype)
("gcc:lib" ,gcc "lib")
("gconf" ,gconf)
("gdk-pixbuf" ,gdk-pixbuf)
("glib" ,glib)
("gtk+" ,gtk+-2)
("libappindicator" ,libappindicator)
("libcap" ,libcap)
("libffi-3.2" ,libffi-3.2)
("libice" ,libice)
("libselinux" ,libselinux)
("libsm" ,libsm)
("libusb" ,libusb)
("libva" ,libva)
("libx11" ,libx11)
("libxcomposite" ,libxcomposite)
("libxcursor" ,libxcursor)
("libxdamage" ,libxdamage)
("libxext" ,libxext)
("libxfixes" ,libxfixes)
("libxi" ,libxi)
("libxinerama" ,libxinerama)
("libxrandr" ,libxrandr)
("libxrender" ,libxrender)
("libxscrnsaver" ,libxscrnsaver)
("libxtst" ,libxtst)
("libxxf86vm" ,libxxf86vm)
("mesa" ,mesa)
("network-manager" ,network-manager)
("nspr" ,nspr)
("nss" ,nss)
("openal" ,openal)
("pango" ,pango)
("pulseaudio" ,pulseaudio)
("sdl2" ,sdl2)
("vulkan-loader" ,vulkan-loader)
("zlib" ,zlib)))
(define steam-gameruntime-libs
`(("ffmpeg" ,ffmpeg)
("flac" ,flac)
("font-dejavu" ,font-dejavu)
("font-liberation" ,font-liberation)
("freeglut" ,freeglut)
("glew" ,glew)
("glu" ,glu)
("gst-plugins-base" ,gst-plugins-base)
("gst-plugins-ugly" ,gst-plugins-ugly)
("gstreamer" ,gstreamer)
("libcaca" ,libcaca)
("libcanberra" ,libcanberra)
("libdrm" ,libdrm)
("libgcrypt-1.5.4" ,libgcrypt-1.5.4)
("libgpg-error" ,libgpg-error)
("libidn" ,libidn)
("libjpeg-turbo" ,libjpeg-turbo)
("libmikmod" ,libmikmod)
("libogg" ,libogg)
("libpciaccess" ,libpciaccess)
("libpng" ,libpng)
("libpng-1.2" ,libpng-1.2)
("librsvg" ,librsvg)
("libsamplerate" ,libsamplerate)
("libtheora" ,libtheora)
("libtiff" ,libtiff)
("libvdpau" ,libvdpau)
("libvorbis" ,libvorbis)
("libvpx" ,libvpx)
("libxcb" ,libxcb)
("libxft" ,libxft)
("libxml2" ,libxml2)
("libxmu" ,libxmu)
("openssl" ,openssl)
("pixman" ,pixman)
("sdl" ,sdl)
("sdl-image" ,sdl-image)
("sdl-mixer" ,sdl-mixer)
("sdl-ttf" ,sdl-ttf)
("sdl2-image" ,sdl2-image)
("sdl2-mixer" ,sdl2-mixer)
("sdl2-ttf" ,sdl2-ttf)
("speex" ,speex)
("sqlite" ,sqlite)
("tbb" ,tbb)
("util-linux" ,util-linux)
("xkeyboard-config" ,xkeyboard-config)))
;;; Building ld.so.conf using find-files from package union results in error
;;; "Argument list too long" when launching Steam.
(define (fhs-ld.so.conf)
"Return a file-like object for ld.so.conf"
(plain-file
"ld.so.conf"
(let ((dirs '("/lib"
"/lib/alsa-lib"
"/lib/dri"
"/lib/nss"
"/lib/vdpau"
"/lib64"
"/lib64/alsa-lib"
"/lib64/dri"
"/lib64/nss"
"/lib64/vdpau")))
(string-join dirs "\n"))))
(define (ld.so.conf->ld.so.cache ld-conf)
(computed-file
"ld.so.cache"
(with-imported-modules
`((guix build utils))
#~(begin
(use-modules (guix build utils))
(let ((ldconfig (string-append #$glibc-for-fhs "/sbin/ldconfig")))
(invoke ldconfig
"-X" ; Don't update symbolic links.
"-f" #$ld-conf ; Use #$configuration as configuration file.
"-C" #$output)))))) ; Use #$output as cache file.
(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
(((names . 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 (nonguix-container->package container)
"Returns a package housing the script launcher-name which executes file at
relative path pkg-run from pkg inside a guix container with an 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))
(container-name (ngc-name container))
(union64 (ngc-union64 container))
(union32 (ngc-union32 container))
(pkg (ngc-wrap-package container)))
(package
(name container-name)
(version (or (ngc-version container)
(package-version pkg)))
(source #f)
(inputs `(,@(if (null? union64)
'() `(("fhs-union-64" ,union64)))
,@(if (null? union32)
'() `(("fhs-union-32" ,union32)))
("fhs-wrapper" ,fhs-wrapper)))
(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"))
(wrapper-target (assoc-ref %build-inputs "fhs-wrapper"))
(wrapper-dest (string-append bin "/" ,container-name)))
(mkdir-p bin)
(symlink wrapper-target wrapper-dest)))))
(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 a guix container for pkg."
(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* ((UID (number->string (passwd:uid (getpwnam (getenv "USER")))))
(run #$(file-append fhs-internal "/bin/" (ngc-internal-name container)))
(manifest-file #$(file-append fhs-manifest))
(home (getenv "HOME"))
(sandbox-home (string-append home "/" #$(ngc-sandbox-home container)))
(preserved-env '("DISPLAY"
"SDL_AUDIODRIVER"
"XAUTHORITY"
"XDG_DATA_HOME"
"XDG_RUNTIME_DIR"))
(expose `("/dev/dri"
"/dev/input" ; Needed for controller input.
,@(exists-> "/etc/machine-id")
"/sys/class/input" ; Needed for controller input.
"/sys/dev"
"/sys/devices"
"/var/run/dbus"))
(share `("/dev/shm"
,(string-append sandbox-home "=" home)
,@(exists-> (string-append home "/.config/pulse"))
,@(exists-> (string-append "/run/user/" UID "/pulse"))
,@(exists-> (string-append "/run/user/" UID "/bus"))
,@(exists-> (getenv "XAUTHORITY"))))
(DEBUG (equal? (getenv "DEBUG") "1"))
(command (if DEBUG '()
`("--" ,run "\"$@\""))))
(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)
(system "pulseaudio -D > /dev/null 2>&1")
(apply system*
`("guix" "environment"
"--ad-hoc" "--container" "--no-cwd" "--network"
,@(map preserve-var preserved-env)
,@(map add-path expose)
,@(map (lambda (item)
(add-path item #:writable? #t))
share)
"-m" ,manifest-file
,@command)))))))
(define (make-container-manifest container fhs-internal)
"Return a scheme file-like object containing a container manifest."
(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 package housing the fhs-internal-script."
(package
(name (ngc-internal-name container))
(version (ngc-version 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 ot set up sandbox")
(description "Script used inside the FHS guix container to setup the
environment.")
(license #f)))
(define (make-internal-script container)
"Return a script file-like object that performas additional setup in the FHS
container before launching pkg-run."
(let* ((ld.so.conf (fhs-ld.so.conf))
(ld.so.cache (ld.so.conf->ld.so.cache ld.so.conf))
(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))
(define (new-symlink target dest)
(unless (file-exists? dest)
(symlink target dest)))
(for-each mkdir-p '("/sbin" "/usr/bin" "/usr/share"
"/run/current-system/profile/etc"
"/run/current-system/profile/share"))
(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))
(args (cdr (command-line))))
(new-symlink (string-append union64 "/lib/locale") "/run/current-system/locale")
(new-symlink (string-append union64 "/share/fonts") "/run/current-system/profile/share/fonts")
(new-symlink (string-append guix-env "/etc/ssl") "/run/current-system/profile/etc/ssl")
(new-symlink (string-append guix-env "/etc/ssl") "/etc/ssl")
(new-symlink (string-append union64 "/bin/env") "/usr/bin/env")
(new-symlink (string-append union64 "/bin/bash") "/bin/bash")
(new-symlink (string-append union64 "/bin/pulseaudio") "/bin/pulseaudio")
(new-symlink (string-append union32 "/lib") "/run/current-system/profile/lib")
(new-symlink (string-append union64 "/lib") "/run/current-system/profile/lib64")
(new-symlink (string-append union32 "/lib") "/lib")
(new-symlink (string-append union64 "/lib") "/lib64")
(new-symlink ld.so.conf "/etc/ld.so.conf")
(new-symlink ld.so.cache "/etc/ld.so.cache")
(new-symlink (string-append union64 "/sbin/ldconfig") "/sbin/ldconfig")
(new-symlink (string-append union64 "/share/vulkan") "/usr/share/vulkan")
(apply system* `(#$(file-append pkg run) ,@args))))))))
(define-public steam
(nonguix-container->package
(nonguix-container
(name "steam")
(wrap-package steam-client)
(run "/bin/steam")
(union64
(fhs-union `(,@steam-client-libs
,@steam-gameruntime-libs
,@fhs-min-libs)
#:name "fhs-union-64"))
(union32
(fhs-union `(,@steam-client-libs
,@steam-gameruntime-libs
,@fhs-min-libs)
#:name "fhs-union-32"
#:system "i686-linux"))
(modules `(base certs compression file gawk gnome linux python))
(packages
`(coreutils
diffutils
file
findutils
gawk
grep
gzip
nss-certs
python
sed
strace
tar
util-linux+udev
which
xz
zenity))
(description "Steam is a digital software distribution platform created by
Valve. This package provides a script for launching Steam in a Guix container
which will use the directory @file{$HOME/.local/share/guix-sandbox-home} where
all games will be installed."))))
Reference in a new issue View git blame Copy permalink