Merge branch 'master' into emacs-team

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 <rekado@elephly.net>
 ;;; Copyright © 2023 Pierre Langlois <pierre.langlois@gmx.com>
+;;; Copyright © 2024 Leo Nikkilä <hello@lnikki.la>
 ;;;
 ;;; 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 <ludo@gnu.org>
+;;; Copyright © 2013-2024 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>
@@ -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