From 9edbb2d7a40c9da7583a1046e39b87633459f656 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Jan 2024 14:55:46 +0100
Subject: =?UTF-8?q?services:=20Add=20=E2=80=98virtual-build-machine?=
 =?UTF-8?q?=E2=80=99=20service.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* gnu/services/virtualization.scm (<virtual-build-machine>): New record type.
(%build-vm-ssh-port, %build-vm-secrets-port, %x86-64-intel-cpu-models):
New variables.
(qemu-cpu-model-for-date, virtual-build-machine-ssh-port)
(virtual-build-machine-secrets-port): New procedures.
(%minimal-vm-syslog-config, %virtual-build-machine-operating-system):
New variables.
(virtual-build-machine-default-image):
(virtual-build-machine-account-name)
(virtual-build-machine-accounts)
(build-vm-shepherd-services)
(initialize-build-vm-substitutes)
(build-vm-activation)
(virtual-build-machine-offloading-ssh-key)
(virtual-build-machine-activation)
(virtual-build-machine-secret-root)
(check-vm-availability)
(build-vm-guix-extension): New procedures.
(initialize-hurd-vm-substitutes): Remove.
(hurd-vm-activation): Rewrite in terms of ‘build-vm-activation’.
* gnu/system/vm.scm (linux-image-startup-command): New procedure.
(operating-system-for-image): Export.
* gnu/tests/virtualization.scm (run-command-over-ssh): New procedure,
extracted from…
(run-childhurd-test): … here.
[test]: Adjust accordingly.
(%build-vm-os): New variable.
(run-build-vm-test): New procedure.
(%test-build-vm): New variable.
* doc/guix.texi (Virtualization Services)[Virtual Build Machines]: New
section.
(Build Environment Setup): Add cross-reference.

Change-Id: I0a47652a583062314020325aedb654f11cb2499c
---
 gnu/system/image.scm |  1 +
 gnu/system/vm.scm    | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 62 insertions(+), 1 deletion(-)

(limited to 'gnu/system')

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/vm.scm b/gnu/system/vm.scm
index ef4c180058..fcfd1cdb48 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -71,6 +71,8 @@
   #:export (virtualized-operating-system
             system-qemu-image/shared-store-script
 
+            linux-image-startup-command
+
             virtual-machine
             virtual-machine?
             virtual-machine-operating-system
@@ -132,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
@@ -316,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.
-- 
cgit v1.2.3