;;; GNU Guix --- Functional package management for GNU
;;; 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>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
;;;
;;; This file is 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 n</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7'>refs</a><a href='/guix/log/etc/git'>log</a><a href='/guix/tree/etc/git?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7'>tree</a><a href='/guix/commit/etc/git?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7'>commit</a><a class='active' href='/guix/diff/etc/git?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7&amp;id2=2c54668d5a575c39055eb221dde8c09eb429b763'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/etc/git'>
<input type='hidden' name='id' value='cc1576d54e36281a39dea0e6e5c29876d4ecc7c7'/><input type='hidden' name='id2' value='2c54668d5a575c39055eb221dde8c09eb429b763'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/diff/?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7&amp;id2=2c54668d5a575c39055eb221dde8c09eb429b763'>root</a>/<a href='/guix/diff/etc?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7&amp;id2=2c54668d5a575c39055eb221dde8c09eb429b763'>etc</a>/<a href='/guix/diff/etc/git?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7&amp;id2=2c54668d5a575c39055eb221dde8c09eb429b763'>git</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='cc1576d54e36281a39dea0e6e5c29876d4ecc7c7'/><input type='hidden' name='id2' value='2c54668d5a575c39055eb221dde8c09eb429b763'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><div class='diffstat-header'><a href='/guix/diff/?id=cc1576d54e36281a39dea0e6e5c29876d4ecc7c7&amp;id2=2c54668d5a575c39055eb221dde8c09eb429b763'>Diffstat</a> (limited to 'etc/git')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
.  Thus, use cache=loose, except for writable
       ;; mounts, to ensure consistency.
       (options (string-append "trans=virtio"
                               (if writable? "" ",cache=loose")
                               ",msize=" (number->string %default-msize-value)))
       (check? #f)
       (create-mount-point? #t)))))

(define* (virtualized-operating-system os
                                       #:optional (mappings '())
                                       #:key (full-boot? #f) volatile?
                                       (system (%current-system))
                                       (target (%current-target-system)))
  "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
<file-system-mapping> to realize in the virtualized OS."
  (define user-file-systems
    ;; Remove file systems that conflict with those added below, or that are
    ;; normally bound to real devices.
    (remove (lambda (fs)
              (let ((target (file-system-mount-point fs))
                    (source (file-system-device fs)))
                (or (string=? target (%store-prefix))
                    (string=? target "/")
                    (and (string? source)
                         (string-prefix? "/dev/" source))

                    ;; Labels and UUIDs are necessarily invalid in the VM.
                    (and (file-system-mount? fs)
                         (or (file-system-label? source)
                             (uuid? source))))))
            (operating-system-file-systems os)))

  (define virtual-file-systems
    (cons (file-system
            (mount-point "/")
            (device "/dev/vda1")
            (type "ext4"))

          (append (map mapping->file-system mappings)
                  user-file-systems)))

  (operating-system
    (inherit os)
    ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
    ;; force the traditional i386/BIOS method.
    ;; See <https://bugs.gnu.org/28768>.
    (bootloader (bootloader-configuration
                 (inherit (operating-system-bootloader os))
                 (bootloader
                  (if (target-riscv64? (or target system))
                      u-boot-qemu-riscv64-bootloader
                      grub-bootloader))
                 (targets '("/dev/vda"))))

    (initrd (lambda (file-systems . rest)
              (apply (operating-system-initrd os)
                     file-systems
                     #:volatile-root? volatile?
                     rest)))
    ;; The (QEMU-only) "cirrus" graphics driver is still expected by some
    ;; VPS with old QEMU versions.  See <https://bugs.gnu.org/36069>.
    (initrd-modules (let ((modules (operating-system-initrd-modules os)))
                      (if (member "cirrus" modules)
                          modules
                          (cons "cirrus" modules))))

    ;; Disable swap.
    (swap-devices '())

    ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
    ;; since that would lead the bootloader config to look for the kernel and
    ;; initrd in it.
    (file-systems (if full-boot?
                      virtual-file-systems
                      (cons
                       (file-system
                         (inherit (mapping->file-system %store-mapping))
                         (needed-for-boot? #t))
                       virtual-file-systems)))))

(define* (common-qemu-options image shared-fs
                              #:key
                              rw-image?
                              (target (%current-target-system)))
  "Return the a string-value gexp with the common QEMU options to boot IMAGE,
with '-virtfs' options for the host file systems listed in SHARED-FS."

  (define (virtfs-option fs)
    #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
              #$fs #$(file-system->mount-tag fs)))

  #~(;; Only enable kvm if we see /dev/kvm exists.
     ;; This allows users without hardware virtualization to still use these
     ;; commands.
     #$@(if (and (not target) (file-exists? "/dev/kvm"))
            '("-enable-kvm")
            '())

     "-no-reboot"
     "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
     "-device" "virtio-rng-pci,rng=guix-vm-rng"

     #$@(map virtfs-option shared-fs)
     #$@(if rw-image?
            #~((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
                                                #:key
                                                (system (%current-system))
                                                (target (%current-target-system))
                                                (qemu qemu)
                                                (graphic? #t)
                                                (volatile? #t)
                                                (memory-size 512)
                                                (mappings '())
                                                full-boot?
                                                (disk-image-size
                                                 (* (if full-boot? 500 70)
                                                    (expt 2 20)))
                                                (options '()))
  "Return a derivation that builds a script to run a virtual machine image of
OS that shares its store with the host.  The virtual machine runs with
MEMORY-SIZE MiB of memory.

MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
systems into the guest.

When FULL-BOOT? is true, the returned script runs everything starting from the
bootloader; otherwise it directly starts the operating system kernel.  When
VOLATILE? is true, an overlay is created on top of a read-only
storage. Otherwise the storage is made persistent.  The DISK-IMAGE-SIZE
parameter specifies the size in bytes of the root disk image; it is mostly
useful when FULL-BOOT?  is true."
  (mlet* %store-monad ((os ->  (virtualized-operating-system
                                os mappings
                                #:full-boot? full-boot?
                                #:volatile? volatile?
                                #:system system
                                #:target target))
                       (base-image -> (system-image
                                       (image
                                        (inherit
                                         (raw-with-offset-disk-image))
                                        (operating-system os)
                                        (size disk-image-size)
                                        (shared-store?
                                         (and (not full-boot?) volatile?))
                                        (volatile-root? volatile?)))))
    (define kernel-arguments
      #~(list #$@(if graphic? #~() #~("console=ttyS0"))
              #$@(operating-system-kernel-arguments os "/dev/vda1")))

    (define rw-image
      #~(format #f "/tmp/guix-image-~a" (basename #$base-image)))

    (define qemu-exec
      #~(list #+(with-parameters ((%current-system %system)
                                  (%current-target-system #f))
                  ;; Override %CURRENT-SYSTEM to always use a native emulator.
                  (file-append qemu "/bin/"
                               (qemu-command (or target system))))
              ;; Tells qemu to use the terminal it was started in for IO.
              #$@(if graphic? '() #~("-nographic"))
              #$@(if full-boot?
                     #~()
                     #~("-kernel" #$(operating-system-kernel-file os)
                        "-initrd" #$(file-append os "/initrd")
                        (format #f "-append ~s"
                                (string-join #$kernel-arguments " "))))
              ;; Default qemu-riscv64 have not PCI, virt have it, so we set it.
              #$@(if (target-riscv64? (or target system))
                     #~("-M" "virt")
                     #~())
              #$@(common-qemu-options (if volatile? base-image rw-image)
                                      (map file-system-mapping-source
                                           (cons %store-mapping mappings))
                                      #:rw-image? (not volatile?)
                                      #:target target)
              "-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"))
            #$@(if volatile?
                   #~()
                   #~((format port "~a~%" #+copy-image)))
            (format port "exec ~a \"$@\"~%"
                    (string-join #$qemu-exec " "))
            (chmod port #o555))))

    (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.
;;;

(define-record-type* <virtual-machine> %virtual-machine
  make-virtual-machine
  virtual-machine?
  (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
                    (default #f))
  (memory-size      virtual-machine-memory-size   ;integer (MiB)
                    (default 256))
  (disk-image-size  virtual-machine-disk-image-size   ;integer (bytes)
                    (default 'guess))
  (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
                    (default '()))
  (date             virtual-machine-date          ;SRFI-19 date | #f
                    (default #f)))

(define-syntax virtual-machine
  (syntax-rules ()
    "Declare a virtual machine running the specified OS, with the given
options."
    ((_ os)                                       ;shortcut
     (%virtual-machine (operating-system os)))
    ((_ fields ...)
     (%virtual-machine fields ...))))

(define (port-forwardings->qemu-options forwardings)
  "Return the QEMU option for the given port FORWARDINGS as a string, where
FORWARDINGS is a list of host-port/guest-port pairs."
  (string-join
   (map (match-lambda
          ((host-port . guest-port)
           (string-append "hostfwd=tcp::"
                          (number->string host-port)
                          "-:" (number->string guest-port))))
        forwardings)
   ","))

(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
                                                system target)
  (match vm
    (($ <virtual-machine> os qemu cpus volatile? graphic? memory-size
                          disk-image-size forwardings date)
     (let ((options
            (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
                                              #:qemu qemu
                                              #:graphic? graphic?
                                              #:volatile? volatile?
                                              #:memory-size memory-size
                                              #:disk-image-size
                                              disk-image-size
                                              #:options options)))))

;;; vm.scm ends here