diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/image.scm | 1 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 88 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 1 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 115 |
4 files changed, 144 insertions, 61 deletions
diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 5456b3a5a0..3082bcff46 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -72,6 +72,7 @@ #:export (root-offset root-label image-without-os + operating-system-for-image esp-partition esp32-partition diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 485baea4c5..c780b68fba 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2020 Google LLC ;;; Copyright © 2022 Ricardo Wurmus <[email protected]> ;;; Copyright © 2023 Pierre Langlois <[email protected]> +;;; Copyright © 2024 Leo Nikkilä <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,7 +57,7 @@ from OS that are needed on the bare metal and not in a container." (if shared-network? (list hosts-service-type) '())))) - (operating-system-default-essential-services os))) + (operating-system-essential-services os))) (cons (service system-service-type `(("locale" ,(operating-system-locale-directory os)))) @@ -144,48 +145,53 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." (list (service dummy-networking-service-type)) '())) + (define os-with-base-essential-services + (operating-system + (inherit os) + (swap-devices '()) ; disable swap + (services + (append services-to-add + (filter-map (lambda (s) + (cond ((memq (service-kind s) services-to-drop) + #f) + ((eq? nscd-service-type (service-kind s)) + (service nscd-service-type + (nscd-configuration + (inherit (service-value s)) + (caches %nscd-container-caches)))) + ((eq? guix-service-type (service-kind s)) + ;; Pass '--disable-chroot' so that + ;; guix-daemon can build thing even in + ;; Docker without '--privileged'. + (service guix-service-type + (guix-configuration + (inherit (service-value s)) + (extra-options + (cons "--disable-chroot" + (guix-configuration-extra-options + (service-value s))))))) + (else s))) + (operating-system-user-services os)))) + (file-systems (append (map mapping->fs + (if shared-network? + (append %network-file-mappings mappings) + mappings)) + extra-file-systems + user-file-systems + + ;; Provide a dummy root file system so we can create + ;; a 'boot-parameters' file. + (list (file-system + (mount-point "/") + (device "nothing") + (type "dummy"))))))) + + ;; `essential-services' is thunked, we need to evaluate it separately. (operating-system - (inherit os) - (swap-devices '()) ; disable swap + (inherit os-with-base-essential-services) (essential-services (container-essential-services - this-operating-system - #:shared-network? shared-network?)) - (services - (append services-to-add - (filter-map (lambda (s) - (cond ((memq (service-kind s) services-to-drop) - #f) - ((eq? nscd-service-type (service-kind s)) - (service nscd-service-type - (nscd-configuration - (inherit (service-value s)) - (caches %nscd-container-caches)))) - ((eq? guix-service-type (service-kind s)) - ;; Pass '--disable-chroot' so that - ;; guix-daemon can build thing even in - ;; Docker without '--privileged'. - (service guix-service-type - (guix-configuration - (inherit (service-value s)) - (extra-options - (cons "--disable-chroot" - (guix-configuration-extra-options - (service-value s))))))) - (else s))) - (operating-system-user-services os)))) - (file-systems (append (map mapping->fs - (if shared-network? - (append %network-file-mappings mappings) - mappings)) - extra-file-systems - user-file-systems - - ;; Provide a dummy root file system so we can create - ;; a 'boot-parameters' file. - (list (file-system - (mount-point "/") - (device "nothing") - (type "dummy"))))))) + os-with-base-essential-services + #:shared-network? shared-network?)))) (define* (container-script os #:key (mappings '()) shared-network?) "Return a derivation of a script that runs OS as a Linux container. diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 8b3958ba5c..d9f13271d8 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -165,6 +165,7 @@ if [ -f ~/.bashrc ]; then . ~/.bashrc; fi # Merge search-paths from multiple profiles, the order matters. eval \"$(guix package --search-paths \\ -p $HOME/.config/guix/current \\ +-p $HOME/.guix-home/profile \\ -p $HOME/.guix-profile \\ -p /run/current-system/profile)\" diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 8c27ff787d..fcfd1cdb48 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <[email protected]> +;;; Copyright © 2013-2024 Ludovic Courtès <[email protected]> ;;; Copyright © 2016 Christine Lemmer-Webber <[email protected]> ;;; Copyright © 2016, 2017 Leo Famulari <[email protected]> ;;; Copyright © 2017 Mathieu Othacehe <[email protected]> @@ -63,6 +63,7 @@ #:use-module (gnu system uuid) #:use-module ((srfi srfi-1) #:hide (partition)) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -70,8 +71,19 @@ #:export (virtualized-operating-system system-qemu-image/shared-store-script + linux-image-startup-command + virtual-machine - virtual-machine?)) + virtual-machine? + virtual-machine-operating-system + virtual-machine-qemu + virtual-machine-cpu-count + virtual-machine-volatile? + virtual-machine-graphic? + virtual-machine-memory-size + virtual-machine-disk-image-size + virtual-machine-port-forwardings + virtual-machine-date)) ;;; Commentary: @@ -122,7 +134,8 @@ (check? #f) (create-mount-point? #t))))) -(define* (virtualized-operating-system os mappings +(define* (virtualized-operating-system os + #:optional (mappings '()) #:key (full-boot? #f) volatile?) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of @@ -306,6 +319,63 @@ useful when FULL-BOOT? is true." (gexp->derivation "run-vm.sh" builder))) +(define* (linux-image-startup-command image + #:key + (system (%current-system)) + (target #f) + (qemu qemu-minimal) + (graphic? #f) + (cpu "max") + (cpu-count 1) + (memory-size 1024) + (port-forwardings '()) + (date #f)) + "Return a list-valued gexp representing the command to start QEMU to run +IMAGE, assuming it uses the Linux kernel, and not sharing the store with the +host." + (define os + ;; Note: 'image-operating-system' would return the wrong OS, before + ;; its root partition has been assigned a UUID. + (operating-system-for-image image)) + + (define kernel-arguments + #~(list #$@(if graphic? #~() #~("console=ttyS0")) + #+@(operating-system-kernel-arguments os "/dev/vda1"))) + + #~`(#+(file-append qemu "/bin/" + (qemu-command (or target system))) + ,@(if (access? "/dev/kvm" (logior R_OK W_OK)) + '("-enable-kvm") + '()) + + "-cpu" #$cpu + #$@(if (> cpu-count 1) + #~("-smp" #$(string-append "cpus=" (number->string cpu-count))) + #~()) + "-m" #$(number->string memory-size) + "-nic" #$(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options port-forwardings)) + "-kernel" #$(operating-system-kernel-file os) + "-initrd" #$(file-append os "/initrd") + "-append" ,(string-join #$kernel-arguments) + "-serial" "stdio" + + #$@(if date + #~("-rtc" + #$(string-append "base=" (date->string date "~5"))) + #~()) + + "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng" + "-device" "virtio-rng-pci,rng=guix-vm-rng" + + "-drive" + ,(string-append "file=" #$(system-image image) + ",format=qcow2,if=virtio," + "cache=writeback,werror=report,readonly=off") + "-snapshot" + "-no-reboot")) + ;;; ;;; High-level abstraction. @@ -317,6 +387,8 @@ useful when FULL-BOOT? is true." (operating-system virtual-machine-operating-system) ;<operating-system> (qemu virtual-machine-qemu ;<package> (default qemu-minimal)) + (cpu-count virtual-machine-cpu-count ;integer + (default 1)) (volatile? virtual-machine-volatile? ;Boolean (default #t)) (graphic? virtual-machine-graphic? ;Boolean @@ -326,7 +398,9 @@ useful when FULL-BOOT? is true." (disk-image-size virtual-machine-disk-image-size ;integer (bytes) (default 'guess)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs - (default '()))) + (default '())) + (date virtual-machine-date ;SRFI-19 date | #f + (default #f))) (define-syntax virtual-machine (syntax-rules () @@ -352,23 +426,24 @@ FORWARDINGS is a list of host-port/guest-port pairs." (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) system target) (match vm - (($ <virtual-machine> os qemu volatile? graphic? memory-size - disk-image-size ()) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:volatile? volatile? - #:memory-size memory-size - #:disk-image-size - disk-image-size)) - (($ <virtual-machine> os qemu volatile? graphic? memory-size - disk-image-size forwardings) + (($ <virtual-machine> os qemu cpus volatile? graphic? memory-size + disk-image-size forwardings date) (let ((options - `("-nic" ,(string-append - "user,model=virtio-net-pci," - (port-forwardings->qemu-options forwardings))))) + (append (if (null? forwardings) + '() + `("-nic" ,(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options + forwardings)))) + (if (> cpus 1) + `("-smp" ,(string-append "cpus=" + (number->string cpus))) + '()) + (if date + `("-rtc" + ,(string-append + "base=" (date->string date "~5"))) + '())))) (system-qemu-image/shared-store-script os #:system system #:target target |