Merge remote-tracking branch 'origin/master' into core-updates

Conflicts:
	doc/guix.texi
	gnu/local.mk
	gnu/packages/admin.scm
	gnu/packages/base.scm
	gnu/packages/chromium.scm
	gnu/packages/compression.scm
	gnu/packages/databases.scm
	gnu/packages/diffoscope.scm
	gnu/packages/freedesktop.scm
	gnu/packages/gnome.scm
	gnu/packages/gnupg.scm
	gnu/packages/guile.scm
	gnu/packages/inkscape.scm
	gnu/packages/llvm.scm
	gnu/packages/openldap.scm
	gnu/packages/pciutils.scm
	gnu/packages/ruby.scm
	gnu/packages/samba.scm
	gnu/packages/sqlite.scm
	gnu/packages/statistics.scm
	gnu/packages/syndication.scm
	gnu/packages/tex.scm
	gnu/packages/tls.scm
	gnu/packages/version-control.scm
	gnu/packages/xml.scm
	guix/build-system/copy.scm
	guix/scripts/home.scm
This commit is contained in:
Efraim Flashner 2023-01-30 11:33:18 +02:00
commit 4cf1acc7f3
No known key found for this signature in database
GPG key ID: 41AAE7DCCA3D8351
740 changed files with 619028 additions and 314277 deletions

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template
;; for a "bare bones" setup for an ASUS C201PA.

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template
;; for a "bare bones" setup, with no X11 display server.
@ -16,6 +17,9 @@
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
(targets '("/dev/sdX"))))
;; It's fitting to support the equally bare bones -nographic
;; QEMU option, which also nicely sidesteps forcing QWERTY.
(kernel-arguments (list "console=ttyS0,115200"))
(file-systems (cons (file-system
(device (file-system-label "my-root"))
(mount-point "/")

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template
;; for a "bare bones" setup on BeagleBone Black board.

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template
;; for a "desktop" setup with GNOME and Xfce where the
;; root partition is encrypted with LUKS, and a swap file.

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template for a "Docker image"
;; setup, so it has barely any services at all.

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration template
;; for a "desktop" setup without full-blown desktop
;; environments.

View file

@ -0,0 +1,71 @@
;; -*- mode: scheme; -*-
;; This is an operating-system configuration template of a
;; 64-bit minimal system for a Raspberry Pi with an NFS root file-system.
;; It neither installs firmware nor device-tree files for the Raspberry Pi.
;; It just assumes them to be existing in boot/efi in the same way that some
;; UEFI firmware with ACPI data is usually assumed to be existing on PCs.
;; It expects the boot/efi directory to be served via TFTP and the root
;; file-system to be served via NFS. See the grub-efi-netboot-bootloader
;; description in the manual for more details.
(use-modules (gnu)
(gnu artwork)
(gnu system nss))
(use-service-modules admin
avahi
networking
ssh)
(use-package-modules certs
linux
raspberry-pi
ssh)
(define-public raspberry-pi-64-nfs-root
(operating-system
(host-name "raspberrypi-guix")
(timezone "Europe/Berlin")
(bootloader (bootloader-configuration
(bootloader grub-efi-bootloader-chain-raspi-64)
(targets (list "/boot/efi"))
(theme (grub-theme
(resolution '(1920 . 1080))
(image (file-append
%artwork-repository
"/grub/GuixSD-fully-black-16-9.svg"))))))
(kernel-arguments '("ip=dhcp"))
(kernel (customize-linux #:linux linux-libre-arm64-generic
#:extra-version "arm64-generic-netboot"
#:configs '("CONFIG_NFS_SWAP=y"
"CONFIG_USB_USBNET=y"
"CONFIG_USB_LAN78XX=y"
"CONFIG_USB_NET_SMSC95XX=y")))
(initrd-modules '())
(file-systems (cons* (file-system
(mount-point "/")
(type "nfs")
(device ":/export/raspberrypi/guix")
(options "addr=10.20.30.40,vers=4.1"))
%base-file-systems))
(swap-devices (list (swap-space
(target "/run/swapfile"))))
(users (cons* (user-account
(name "pi")
(group "users")
(supplementary-groups '("wheel" "netdev" "audio" "video"))
(home-directory "/home/pi"))
%base-user-accounts))
(packages (cons* nss-certs
openssh
%base-packages))
(services (cons* (service avahi-service-type)
(service dhcp-client-service-type)
(service ntp-service-type)
(service openssh-service-type
(openssh-configuration
(x11-forwarding? #t)))
%base-services))
(name-service-switch %mdns-host-lookup-nss)))
raspberry-pi-64-nfs-root

View file

@ -0,0 +1,75 @@
;; -*- mode: scheme; -*-
;; This is an operating-system configuration template of a
;; 64-bit minimal system for a Raspberry Pi with local storage.
;; It neither installs firmware nor device-tree files for the Raspberry Pi.
;; It just assumes them to be existing in boot/efi in the same way that some
;; UEFI firmware with ACPI data is usually assumed to be existing on PCs.
;; It expects the boot-partition to be mounted as boot/efi in the same way
;; as it is usually expeted on PCs with UEFI firmware.
(use-modules (gnu)
(gnu artwork)
(gnu system nss))
(use-service-modules admin
avahi
networking
ssh)
(use-package-modules certs
linux
raspberry-pi
ssh)
(define-public raspberry-pi-64
(operating-system
(host-name "raspberrypi-guix")
(timezone "Europe/Berlin")
(bootloader (bootloader-configuration
(bootloader grub-efi-bootloader-chain-raspi-64)
(targets (list "/boot/efi"))
(theme (grub-theme
(resolution '(1920 . 1080))
(image (file-append
%artwork-repository
"/grub/GuixSD-fully-black-16-9.svg"))))))
(kernel (customize-linux #:linux linux-libre-arm64-generic
;; It is possible to use a specific defconfig
;; file, for example the "bcmrpi3_defconfig" with
;; the variable shown below. Unfortunately the
;; kernel built from the linux-libre sources with
;; this defconfig file does not boot.
;;#:extra-version "gnu-bcmrpi3"
;;#:defconfig %bcmrpi3-defconfig
))
(initrd-modules '())
(file-systems (cons* (file-system
(mount-point "/")
(type "ext4")
(device (file-system-label "Guix")))
(file-system
(mount-point "/boot/efi")
(type "vfat")
(device (file-system-label "EFI")))
%base-file-systems))
(swap-devices (list (swap-space
(target "/run/swapfile"))))
(users (cons* (user-account
(name "pi")
(group "users")
(supplementary-groups '("wheel" "netdev" "audio" "video"))
(home-directory "/home/pi"))
%base-user-accounts))
(packages (cons* nss-certs
openssh
%base-packages))
(services (cons* (service avahi-service-type)
(service dhcp-client-service-type)
(service ntp-service-type)
(service openssh-service-type
(openssh-configuration
(x11-forwarding? #t)))
%base-services))
(name-service-switch %mdns-host-lookup-nss)))
raspberry-pi-64

View file

@ -1,3 +1,4 @@
;; -*- mode: scheme; -*-
;; This is an operating system configuration for a VM image.
;; Modify it as you see fit and instantiate the changes by running:
;;

View file

@ -1,60 +0,0 @@
;; This is an operating system configuration template
;; for a "bare bones" setup, with no X11 display server.
(use-modules (gnu))
(use-service-modules networking ssh)
(use-package-modules admin curl networking screen)
(operating-system
(host-name "ruby-guard-5545")
(timezone "Europe/Budapest")
(locale "en_US.utf8")
;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the
;; target hard disk, and "my-root" is the label of the target
;; root file system.
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
(targets '("/dev/sdX"))))
(file-systems (cons (file-system
(device (file-system-label "my-root"))
(mount-point "/")
(type "ext4"))
%base-file-systems))
(users (cons (user-account
(name "alice")
(comment "Bob's sister")
(group "users")
;; adding her to the yggdrasil group means she can use
;; yggdrasilctl to modify the configuration
(supplementary-groups '("wheel" "yggdrasil")))
%base-user-accounts))
;; Globally-installed packages.
(packages (cons* screen curl %base-packages))
;; Add services to the baseline: a DHCP client and
;; an SSH server.
;; If you add an /etc/yggdrasil-private.conf, you can log in to ssh
;; using your Yggdrasil IPv6 address from another machine running Yggdrasil.
;; Alternatively, the client can sit behind a router that has Yggdrasil.
;; That file is specifically _not_ handled by Guix, because we don't want its
;; contents to sit in the world-readable /gnu/store.
(services
(append
(list
(service dhcp-client-service-type)
(service yggdrasil-service-type
(yggdrasil-configuration
(log-to 'stdout)
(log-level 'debug)
(autoconf? #f)
(json-config
;; choose a few from
;; https://github.com/yggdrasil-network/public-peers
'((peers . #("tcp://1.2.3.4:1337"))))
(config-file #f)))
(service openssh-service-type
(openssh-configuration
(port-number 2222))))
%base-services)))

View file

@ -75,28 +75,30 @@
info-reader))
(define %base-services/hurd
(list (service hurd-console-service-type
(hurd-console-configuration (hurd hurd)))
(service hurd-getty-service-type (hurd-getty-configuration
(tty "tty1")))
(service hurd-getty-service-type (hurd-getty-configuration
(tty "tty2")))
(service static-networking-service-type
(list %loopback-static-networking
(append (list (service hurd-console-service-type
(hurd-console-configuration (hurd hurd)))
(service static-networking-service-type
(list %loopback-static-networking
;; QEMU user-mode networking. To get "eth0", you need
;; QEMU to emulate a device for which Mach has an
;; in-kernel driver, for instance with:
;; --device rtl8139,netdev=net0 --netdev user,id=net0
%qemu-static-networking))
(syslog-service)
(service guix-service-type
(guix-configuration
(extra-options '("--disable-chroot"
"--disable-deduplication"))))
(service special-files-service-type
`(("/bin/sh" ,(file-append bash "/bin/sh"))
("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
;; QEMU user-mode networking. To get "eth0", you need
;; QEMU to emulate a device for which Mach has an
;; in-kernel driver, for instance with:
;; --device rtl8139,netdev=net0 --netdev user,id=net0
%qemu-static-networking))
(service guix-service-type
(guix-configuration
(extra-options '("--disable-chroot"
"--disable-deduplication"))))
(service special-files-service-type
`(("/bin/sh" ,(file-append bash "/bin/sh"))
("/usr/bin/env" ,(file-append coreutils
"/bin/env"))))
(syslog-service))
(map (lambda (n)
(service hurd-getty-service-type
(hurd-getty-configuration
(tty (string-append "tty" (number->string n))))))
(iota 6 1))))
(define %setuid-programs/hurd
;; Default set of setuid-root programs.

View file

@ -138,6 +138,9 @@ parent image record."
(size 'guess)
(label root-label)
(file-system "ext4")
;; Disable the metadata_csum and 64bit features of ext4, for compatibility
;; with U-Boot.
(file-system-options (list "-O" "^metadata_csum,^64bit"))
(flags '(boot))
(initializer (gexp initialize-root-partition))))
@ -652,6 +655,8 @@ output file."
shared-network?)
(list boot-program)))
(substitutable? (image-substitutable? image))
(image-target (or (%current-target-system)
(nix-system->gnu-triplet)))
(register-closures? (has-guix-service-type? os))
(schema (and register-closures?
(local-file (search-path %load-path
@ -705,6 +710,7 @@ output file."
#:entry-point '(#$boot-program #$os)
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:system #$image-target
#:transformations `((,image-root -> ""))))))))
(computed-file name builder
@ -969,9 +975,9 @@ image, depending on IMAGE format."
(G_ "~a: unsupported image format") image-format)))))))
;;
;; Image detection.
;;
;;;
;;; Image type discovery.
;;;
(define (image-modules)
"Return the list of image modules."

View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2022 Gabriel Wicki <gabriel@erlikon.ch>
;;;
;;; This file is part of GNU Guix.
;;;
@ -21,9 +22,11 @@
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages linux)
#:use-module (gnu packages certs)
#:use-module (guix platforms arm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services networking)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system image)
@ -47,13 +50,17 @@
(mount-point "/")
(type "ext4"))
%base-file-systems))
(services (cons (service agetty-service-type
(agetty-configuration
(extra-options '("-L")) ; no carrier detect
(baud-rate "115200")
(term "vt100")
(tty "ttyS0")))
%base-services))))
(services (cons*
(service agetty-service-type
(agetty-configuration
(extra-options '("-L")) ; no carrier detect
(baud-rate "115200")
(term "vt100")
(tty "ttyS0")))
(service dhcp-client-service-type)
(service ntp-service-type)
%base-services))
(packages (cons nss-certs %base-packages))))
(define pine64-image-type
(image-type

View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2022 dan <i@dan.games>
;;;
;;; This file is part of GNU Guix.
;;;
@ -33,6 +34,7 @@
#:use-module (guix build-system trivial)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module ((guix licenses) #:select (fsdg-compatible))
#:export (wsl-boot-program
wsl-os
wsl2-image))
@ -74,7 +76,11 @@ USER."
(let* ((pw (getpw #$user))
(shell (passwd:shell pw))
(sudo #+(file-append sudo "/bin/sudo"))
(args (cdr (command-line))))
(args (cdr (command-line)))
(uid (passwd:uid pw))
(gid (passwd:gid pw))
(runtime-dir (string-append "/run/user/"
(number->string uid))))
;; Save the value of $PATH set by WSL. Useful for finding
;; Windows binaries to run with WSL's binfmt interop.
(setenv "WSLPATH" (getenv "PATH"))
@ -87,9 +93,15 @@ USER."
MS_REMOUNT
#:update-mtab? #f)
;; Create XDG_RUNTIME_DIR for the login user.
(unless (file-exists? runtime-dir)
(mkdir runtime-dir)
(chown runtime-dir uid gid))
(setenv "XDG_RUNTIME_DIR" runtime-dir)
;; Start login shell as user.
(apply execl sudo "sudo"
"--preserve-env=WSLPATH"
"--preserve-env=WSLPATH,XDG_RUNTIME_DIR"
"-u" #$user
"--"
shell "-l" args))))))
@ -113,7 +125,7 @@ USER."
(home-page #f)
(synopsis #f)
(description #f)
(license #f)))
(license (fsdg-compatible "dummy"))))
(define dummy-bootloader
(bootloader

View file

@ -48,6 +48,9 @@
#:use-module (gnu packages bootloaders)
#:use-module (gnu packages certs)
#:use-module (gnu packages compression)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages disk)
#:use-module (gnu packages file-systems)
#:use-module (gnu packages fonts)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages guile)
@ -281,13 +284,24 @@ templates under @file{/etc/configuration}.")))
;; appropriate options. The GUI installer needs it when the machine does not
;; support Kernel Mode Setting. Otherwise kmscon is missing /dev/fb0.
(define (uvesafb-shepherd-service _)
(define modprobe
(program-file "modprobe-wrapper"
#~(begin
;; Use a wrapper because shepherd 0.9.3 won't let us
;; pass environment variables to the child process:
;; <https://issues.guix.gnu.org/60106>.
(setenv "LINUX_MODULE_DIRECTORY"
"/run/booted-system/kernel/lib/modules")
(apply execl #$(file-append kmod "/bin/modprobe")
"modprobe" (cdr (command-line))))))
(list (shepherd-service
(documentation "Load the uvesafb kernel module if needed.")
(provision '(maybe-uvesafb))
(requirement '(file-systems))
(start #~(lambda ()
(or (file-exists? "/dev/fb0")
(invoke #+(file-append kmod "/bin/modprobe")
(invoke #+modprobe
"uvesafb"
(string-append "v86d=" #$v86d "/sbin/v86d")
"mode_option=1024x768"))))
@ -458,6 +472,23 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
\x1b[1;33mUse Alt-F2 for documentation.\x1b[0m
")
(define %installer-disk-utilities
;; A well-rounded set of packages for interacting with disks, partitions and
;; file systems, included with the Guix installation image.
(list parted gptfdisk ddrescue
;; Use the static LVM2 because it's already pulled in by the installer.
lvm2-static
;; We used to provide fdisk from GNU fdisk, but as of version 2.0.0a
;; it pulls Guile 1.8, which takes unreasonable space; furthermore
;; util-linux's fdisk is already available, in %base-packages-linux.
cryptsetup mdadm
dosfstools
btrfs-progs
e2fsprogs
f2fs-tools
jfsutils
xfsprogs))
(define installation-os
;; The operating system used on installation images for USB sticks etc.
(operating-system
@ -530,7 +561,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
font-dejavu font-gnu-unifont
grub ; mostly so xrefs to its manual work
nss-certs) ; To access HTTPS, use git, etc.
%base-packages-disk-utilities
%installer-disk-utilities
%base-packages))))
(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")

View file

@ -121,9 +121,7 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
;; different configs that are better suited to containers.
(append (list console-font-service-type
mingetty-service-type
agetty-service-type
;; Reinstantiated below with smaller caches.
nscd-service-type)
agetty-service-type)
(if shared-network?
;; Replace these with dummy-networking-service-type below.
(list
@ -134,17 +132,13 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
(list))))
(define services-to-add
(append
;; Many Guix services depend on a 'networking' shepherd
;; service, so make sure to provide a dummy 'networking'
;; service when we are sure that networking is already set up
;; in the host and can be used. That prevents double setup.
(if shared-network?
(list (service dummy-networking-service-type))
'())
(list
(nscd-service (nscd-configuration
(caches %nscd-container-caches))))))
;; Many Guix services depend on a 'networking' shepherd
;; service, so make sure to provide a dummy 'networking'
;; service when we are sure that networking is already set up
;; in the host and can be used. That prevents double setup.
(if shared-network?
(list (service dummy-networking-service-type))
'()))
(operating-system
(inherit os)
@ -155,7 +149,11 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
(services (append (remove (lambda (service)
(memq (service-kind service)
services-to-drop))
(operating-system-user-services os))
(modify-services (operating-system-user-services os)
(nscd-service-type
config => (nscd-configuration
(inherit config)
(caches %nscd-container-caches)))))
services-to-add))
(file-systems (append (map mapping->fs
(if shared-network?

View file

@ -172,6 +172,7 @@ MODULES and taken from LINUX."
#:key
(linux linux-libre)
(linux-modules '())
(pre-mount #t)
(mapped-devices '())
(keyboard-layout #f)
(helper-packages '())
@ -183,7 +184,8 @@ modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
mounted by the initrd, possibly in addition to the root file system specified
on the kernel command line via 'root'. LINUX-MODULES is a list of kernel
modules to be loaded at boot time. MAPPED-DEVICES is a list of device
mappings to realize before FILE-SYSTEMS are mounted.
mappings to realize before FILE-SYSTEMS are mounted. PRE-MOUNT is a
G-expression to evaluate before realizing MAPPED-DEVICES.
HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
e2fsck/static or other packages needed by the initrd to check root partition.
@ -255,7 +257,8 @@ upon error."
(map spec->file-system
'#$(map file-system->spec file-systems))
#:pre-mount (lambda ()
(and #$@device-mapping-commands
(and #$pre-mount
#$@device-mapping-commands
#$@file-system-scan-commands))
#:linux-modules '#$linux-modules
#:linux-module-directory '#$kodir

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
@ -63,7 +63,8 @@
user-group-id
user-group-system?)
#:export (default-skeletons
#:export (%default-bashrc
default-skeletons
skeleton-directory
%base-groups
%base-user-accounts
@ -118,14 +119,8 @@
(create-home-directory? #f)
(system? #t))))
(define (default-skeletons)
"Return the default skeleton files for /etc/skel. These files are copied by
'useradd' in the home directory of newly created user accounts."
(let ((profile (plain-file "bash_profile" "\
# Honor per-interactive-shell startup file
if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
(bashrc (plain-file "bashrc" "\
(define %default-bashrc
(plain-file "bashrc" "\
# Bash initialization for interactive non-login shells and
# for remote shells (info \"(bash) Bash Startup Files\").
@ -145,18 +140,20 @@ then
fi
# Source the system-wide file.
source /etc/bashrc
[ -f /etc/bashrc ] && source /etc/bashrc
# Adjust the prompt depending on whether we're in 'guix environment'.
if [ -n \"$GUIX_ENVIRONMENT\" ]
then
PS1='\\u@\\h \\w [env]\\$ '
else
PS1='\\u@\\h \\w\\$ '
fi
alias ls='ls -p --color=auto'
alias ll='ls -l'
alias grep='grep --color=auto'\n"))
(define (default-skeletons)
"Return the default skeleton files for /etc/skel. These files are copied by
'useradd' in the home directory of newly created user accounts."
(let ((profile (plain-file "bash_profile" "\
# Honor per-interactive-shell startup file
if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
(bashrc %default-bashrc)
(zprofile (plain-file "zprofile" "\
# Honor system-wide environment variables
source /etc/profile\n"))

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@ -234,8 +234,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
#$@(map virtfs-option shared-fs)
#$@(if rw-image?
#~((format #f "-drive file=~a,if=virtio" #$image))
#~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
#~((format #f "-drive file=~a,format=qcow2,if=virtio" #$image))
#~((format #f "-drive file=~a,format=raw,if=virtio,cache=writeback,werror=report,readonly=on"
#$image)))))
(define* (system-qemu-image/shared-store-script os
@ -303,17 +303,26 @@ useful when FULL-BOOT? is true."
"-m " (number->string #$memory-size)
#$@options))
(define copy-image
;; Script that "copies" BASE-IMAGE to /tmp. Make a copy-on-write image,
;; which is much cheaper than actually copying it.
(program-file "copy-image"
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(unless (file-exists? #$rw-image)
(invoke #+(file-append qemu "/bin/qemu-img")
"create" "-b" #$base-image
"-F" "raw" "-f" "qcow2" #$rw-image))))))
(define builder
#~(call-with-output-file #$output
(lambda (port)
(format port "#!~a~%"
#+(file-append bash "/bin/sh"))
(when (not #$volatile?)
(format port "~a~%"
#$(program-file "copy-image"
#~(unless (file-exists? #$rw-image)
(copy-file #$base-image #$rw-image)
(chmod #$rw-image #o640)))))
#$@(if volatile?
#~()
#~((format port "~a~%" #+copy-image)))
(format port "exec ~a \"$@\"~%"
(string-join #$qemu-exec " "))
(chmod port #o555))))