[bug#72249] [PATCH 2/2] services: Add xe-guest-utilities-service-type.

[Karl Hallsby]

* gnu/services/virtualization.scm (xe-guest-utilities-configuration,
  xe-guest-utilities-service-type): New variables.

Change-Id: Ife4e79fa6d1a9d5a21bf7479488884f2a5cf8d56
---
 doc/guix.texi                   |  30 ++++++
 gnu/services/virtualization.scm | 178 +++++++++++++++++++++++++++++++-
 2 files changed, 207 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 9ba96af459..6a29731b95 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -36873,6 +36873,36 @@ Virtualization Services
 @end table
 @end deftp
 
+@subsubheading Xen Guest Agent
+
+@cindex xen
+@cindex xen guest agent
+
+The Xen guest agent allows a Xen host to control the emulated system.
+The @code{xe-guest-agent} service runs the agent on Guix guests.
+
+@quotation Note
+The default Linux-libre kernel that Guix ships already enables the
+necessary features for a guest.  There is nothing you need to enable for
+the guest to fully support paravirtualization features.
+@end quotation
+
+@defvar xe-guest-agent-service-type
+Service type for the QEMU guest agent service.
+@end defvar
+
+@deftp {Data Type} xe-guest-agent-configuration
+Configuration for the @code{xen-guest-agent} service.
+
+@table @asis
+@item @code{package} (default: @code{xen-guest-utilities})
+The Xen guest utilities package to use.
+
+@item @code{pid-file} (default: @code{"/var/run/xe-daemon.pid"})
+Path to the file holding the PID of xe-deamon.
+@end table
+@end deftp
+
 
 @anchor{build-vm}
 @subsubheading Virtual Build Machines
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index c9f8225570..29d5de6cc7 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -33,6 +33,9 @@ (define-module (gnu services virtualization)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages ssh)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages gawk)
+  #:use-module (gnu packages linux)
   #:use-module (gnu packages virtualization)
   #:use-module (gnu services base)
   #:use-module (gnu services configuration)
@@ -107,7 +110,10 @@ (define-module (gnu services virtualization)
 
             qemu-guest-agent-configuration
             qemu-guest-agent-configuration?
-            qemu-guest-agent-service-type))
+            qemu-guest-agent-service-type
+
+            xe-guest-agent-configuration
+            xe-guest-agent-service-type))
 
 (define (uglify-field-name field-name)
   (let ((str (symbol->string field-name)))
@@ -1004,6 +1010,77 @@ (define qemu-guest-agent-service-type
    (default-value (qemu-guest-agent-configuration))
    (description "Run the QEMU guest agent.")))
 
+
+;;;
+;;; Guest agent for VMs running under Xen
+;;;
+(define-configuration/no-serialization xe-guest-agent-configuration
+  (package
+   (package xe-guest-utilities)
+   "Xen guest management utilities package.")
+  (pid-file
+   (string "/var/run/xe-daemon.pid")
+   "Path to the file holding the PID of xe-deamon."))
+
+(define (generate-xe-guest-agent-documentation)
+  "Generate documentation for xe-guest-agent fields"
+  (generate-documentation
+   `((xe-guest-agent-configuration ,xe-guest-agent-configuration-fields))
+   'xe-guest-agent-configuration))
+
+(define (xe-guest-agent-shepherd-service config)
+  (let ((xe-guest-utils (xe-guest-agent-configuration-package config))
+        (pid-file (xe-guest-agent-configuration-pid-file config)))
+    (list
+     (shepherd-service
+      (provision '(xe-guest-agent))
+      (requirement '(networking user-processes udev))
+      (documentation "Run the Xen guest management agent.")
+      (start
+       #~(lambda _
+           (let ((pid (make-forkexec-constructor
+                       (list
+                        #$(file-append xe-guest-utils
+                                       "/sbin/xe-daemon")
+                        "-p" #$pid-file)
+                       #:log-file "/var/log/xe-daemon.log"
+                       #:pid-file #$pid-file
+                       #:environment-variables
+                       (list (string-append
+                              "PATH="
+                              #$(file-append xe-guest-utils "/bin") ":"
+                              ;; logger
+                              #$(file-append inetutils "/bin"))))))
+             ;; Run xe-linux-distribution script before starting the actual
+             ;; daemon. The script collects some basic system information that
+             ;; is shared back to the Xen host.
+             (system* #$(file-append xe-guest-utils 
"/sbin/xe-linux-distribution")
+                      "/var/cache/xe-linux-distribution")
+             ;; Finally, start and return the PID made by
+             ;; make-forkexec-constructor.
+             pid)))
+      (stop #~(make-kill-destructor))))))
+
+(define (xe-guest-agent-udev-rules-service config)
+  (let ((guest-utils (xe-guest-agent-configuration-package config)))
+    (list
+     (file->udev-rule "z10_xen-vcpu-hotplug.rules"
+                      (file-append
+                       guest-utils
+                       ;; I hate this z10_ prefix too
+                       "/lib/udev/rules.d/z10_xen-vcpu-hotplug.rules")))))
+
+(define xe-guest-agent-service-type
+  (service-type
+   (name 'xe-guest-agent)
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             xe-guest-agent-shepherd-service)
+          (service-extension udev-service-type
+                             xe-guest-agent-udev-rules-service)))
+   (default-value (xe-guest-agent-configuration))
+   (description "Run the Xen guest management utilities.")))
+
 
 ;;;
 ;;; Secrets for guest VMs.
@@ -1860,3 +1937,102 @@ (define hurd-vm-service-type
    (description
     "Provide a virtual machine (VM) running GNU/Hurd, also known as a
 @dfn{childhurd}.")))
+
+(define-configuration/no-serialization xe-guest-utilities-configuration
+  (xe-guest-utilities
+   (file-like xe-guest-utilities)
+   "XenServer guest utilities package.")
+  (pid-file
+   (string "/var/run/xe-daemon.pid")
+   "File holding the PID of xe-deamon."))
+
+(define (generate-xe-guest-utilities-documentation)
+  "Generate documentation for xe-guest-utilities fields"
+  (generate-documentation
+   `((xe-guest-utilities-configuration 
,xe-guest-utilities-configuration-fields))
+   'xe-guest-utilities-configuration))
+
+(define (xe-guest-utils-service config)
+  (let ((pid-file (xe-guest-utilities-configuration-pid-file config)))
+    (list
+     ;; Generate <shepherd-service>s that run the xe-daemon forever.
+     (shepherd-service
+      (documentation "Run the xe-guest-utilities daemon.")
+      (provision '(xe-guest-utilities-daemon))
+      (requirement '(xe-guest-utilities-procfs
+                     xe-guest-utilities-distro))
+      (start #~(make-forkexec-constructor
+                (list #$(file-append xe-guest-utilities "/bin/xe-daemon")
+                      "-p" #$pid-file)
+                #:pid-file #$pid-file
+                #:environment-variables
+                (list (string-append
+                       "PATH=/run/current-system/profile/bin:"
+                       "/run/current-system/profile/sbin:"
+                       #$(file-append coreutils "/bin") ":"
+                       #$(file-append iproute "/bin")))))
+      (stop #~(make-kill-destructor)))
+
+  ;; Generate one-shot <shepherd-service>s that informs the host hypervisor 
about
+  ;; the distribution of the guest (Guix in this case)
+  (shepherd-service
+   (documentation "Inform host hypervisor of guest's distribution.")
+   (provision '(xe-guest-utilities-distro))
+   (requirement '(;;xe-guest-utilities-xend
+                  ))
+   (one-shot? #t)
+   (start #~(make-forkexec-constructor
+             (list #$(file-append xe-guest-utilities 
"/bin/xe-linux-distribution")
+                   "/var/run/xe-linux-distribution")
+             #:environment-variables
+             (list (string-append
+                    "PATH="
+                    #$(file-append xe-guest-utilities "/bin") ":"
+                    #$(file-append coreutils "/bin") ":" ;uname & co
+                    #$(file-append gawk "/bin") ":"
+                    #$(file-append sed "/bin")))))
+   (stop #~(make-kill-destructor)))
+
+  ;; Generate <shepherd-service>s to mount the xen directory in /proc.
+  (shepherd-service
+   (documentation "Mount /proc/xen files.")
+   (provision '(xe-guest-utilities-procfs))
+   (requirement '(file-systems))
+   (start #~(lambda ()
+              (mount "xenfs" "/proc/xen" "/proc/xen")
+              (member "/proc/xen" (mount-points))))
+   (stop #~(lambda ()
+             (umount "/proc/xen" MNT_DETACH)
+             (not (member "/proc/xen" (mount-points))))))
+
+  ;; Generate <shepherd-service>s to create the necessary temporary 
directories for XenStore.
+  (shepherd-service
+   (documentation "Provide a temporary directory for XenStore.")
+   (provision '(xe-guest-utilities-tmp-dir))
+   (one-shot? #t)
+   (requirement '(file-systems))
+   (start #~(lambda ()
+              (mkdir "/var/run/xenstored")
+              (chmod o755 "/var/run/xenstored")))
+   (stop #~(lambda ()
+             (delete-file-recursively "/var/run/xenstored")))))))
+
+(define (xe-guest-utils-udev-rules-service config)
+  (let ((guest-utils (xe-guest-utilities-configuration-xe-guest-utilities 
config)))
+    (list
+     (file->udev-rule "z10_xen-vcpu-hotplug.rules"
+                      (file-append
+                       guest-utils
+                       ;; I hate this z10_ prefix too
+                       "/etc/udev/rules.d/z10_xen-vcpu-hotplug.rules")))))
+
+(define xe-guest-utilities-service-type
+  (service-type
+   (name 'xe-guest-utilities)
+   (extensions (list (service-extension shepherd-root-service-type
+                                        xe-guest-utils-service)
+                     (service-extension udev-service-type
+                                        xe-guest-utils-udev-rules-service)))
+   (default-value (xe-guest-utilities-configuration))
+   (description
+    "Enable a Guix System VM to communicate with a Xen-based hypervisor 
host.")))
-- 
2.45.2