[bug#75027] [PATCH v2 3/3] reconfigure: Support loading the system for kexec reboot.

["Ludovic Courtès" <ludo@gnu.org>]

This allows rebooting straight into the new system with ‘reboot -k’.

* guix/scripts/system/reconfigure.scm (kexec-loading-program)
(load-system-for-kexec): New procedures.
* gnu/tests/reconfigure.scm (run-kexec-test): New procedure.
(%test-upgrade-kexec): New variable.
* guix/scripts/system.scm (perform-action): Add #:load-for-kexec?.
Call ‘load-system-for-kexec’.
(show-help, %options): Add ‘--no-kexec’.
(%default-options): Add ‘load-for-kexec?’.
(process-action): Honor it and pass it to ‘perform-action’.
* gnu/machine/ssh.scm (deploy-managed-host): Add call to
‘load-system-for-kexec’.
* doc/guix.texi (Invoking guix system): Document it.

Change-Id: I86d11f1c348e4359bc9e73c86e5aebff60fe875c
---
 doc/guix.texi                       | 11 +++-
 gnu/machine/ssh.scm                 |  9 +++-
 gnu/tests/reconfigure.scm           | 78 +++++++++++++++++++++++++++++
 guix/scripts/system.scm             | 17 ++++++-
 guix/scripts/system/reconfigure.scm | 31 ++++++++++++
 5 files changed, 143 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index da4d2f5ebc..7bf14a49e9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -43599,11 +43599,20 @@ Invoking guix system
 overwritten.  This behavior mirrors that of @command{guix package}
 (@pxref{Invoking guix package}).
 
-It also adds a bootloader menu entry for the new OS configuration,
+It adds a bootloader menu entry for the new OS configuration,
 ---unless @option{--no-bootloader} is passed.  For GRUB, it moves
 entries for older configurations to a submenu, allowing you to choose
 an older system generation at boot time should you need it.
 
+@cindex kexec, for fast reboots
+@cindex rebooting @i{via} Linux kexec
+On Linux, @command{guix system reconfigure} also loads the new system
+for fast reboot @i{via} kexec: running @command{reboot --kexec} will
+boot the new system by directly executing its kernel, thus bypassing the
+BIOS initialization phase and bootloader (@pxref{Invoking reboot,,,
+shepherd, The GNU Shepherd Manual}).  You can avoid this behavior by
+passing the @option{--no-kexec} option.
+
 @cindex provenance tracking, of the operating system
 Upon completion, the new system is deployed under
 @file{/run/current-system}.  This directory contains @dfn{provenance
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 3e10d984e7..f58fcdaf4a 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
-;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Ricardo <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -552,6 +552,13 @@ (define (deploy-managed-host machine)
                                                       (inferior-exception-arguments
                                                        c)))
                                            os)
+                (load-system-for-kexec (eval/error-handling c
+                                         (warning (G_ "\
+failed to load system of '~a' for kexec reboot:~%~{~s ~}~%")
+                                                  host
+                                                  (inferior-exception-arguments
+                                                   c)))
+                                       os)
                 (install-bootloader (eval/error-handling c
                                       (raise (formatted-message
                                               (G_ "\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
index bcc7645fa3..a24a953e6e 100644
--- a/gnu/tests/reconfigure.scm
+++ b/gnu/tests/reconfigure.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,9 +19,12 @@
 
 (define-module (gnu tests reconfigure)
   #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system)
   #:use-module (gnu system accounts)
+  #:use-module (gnu system file-systems)
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu tests)
@@ -31,6 +35,7 @@ (define-module (gnu tests reconfigure)
   #:use-module (guix store)
   #:export (%test-switch-to-system
             %test-upgrade-services
+            %test-upgrade-kexec
             %test-install-bootloader))
 
 ;;; Commentary:
@@ -178,6 +183,73 @@ (define* (run-upgrade-services-test)
           (disable (upgrade-services-program '() '() '(dummy) '())))
      (test enable disable))))
 
+(define (run-kexec-test)
+  "Run a test aiming to reboot via Linux kexec into a new system."
+  (define os
+    (marionette-operating-system
+     (operating-system
+       (inherit %simple-os)
+       (services (modify-services %base-services
+                   (syslog-service-type
+                    config => (syslog-configuration
+                               (inherit config)
+                               (config-file
+                                (plain-file
+                                 "syslog.conf"
+                                 "*.* /dev/console\n")))))))
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define new-os
+    (marionette-operating-system
+     (virtualized-operating-system               ;run as with "guix system vm"
+      (operating-system
+        (inherit %simple-os)
+        (host-name "the-new-os")
+        (kernel-arguments '("console=ttyS0")))    ;be verbose
+      #:volatile? #t)                             ;mount root read-only
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "kexec")
+
+          (test-equal "host name"
+            #$(operating-system-host-name os)
+            (marionette-eval '(gethostname) marionette))
+
+          (test-assert "kexec-loading-program"
+            (marionette-eval
+             '(primitive-load #$(kexec-loading-program new-os))
+             marionette))
+
+          (test-assert "reboot/kexec"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (with-shepherd-action 'root ('kexec) result
+                  (pk 'reboot-kexec result)))
+             marionette))
+
+          (test-equal "host name of new OS"
+            #$(operating-system-host-name new-os)
+            (marionette-eval '(gethostname) marionette))
+
+          (test-end))))
+
+  (gexp->derivation "kexec-test" test))
+
 (define* (run-install-bootloader-test)
   "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
 bootloader's configuration file."
@@ -268,6 +340,12 @@ (define %test-upgrade-services
 loading new services.")
    (value (run-upgrade-services-test))))
 
+(define %test-upgrade-kexec
+  (system-test
+   (name "upgrade-kexec")
+   (description "Load a system and reboot into it via Linux kexec.")
+   (value (run-kexec-test))))
+
 (define %test-install-bootloader
   (system-test
    (name "install-bootloader")
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index dd34f6cd15..f174c8ada1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -798,6 +798,7 @@ (define* (perform-action action image
                          save-provenance?
                          skip-safety-checks?
                          install-bootloader?
+                         load-for-kexec?
                          dry-run? derivations-only?
                          use-substitutes? target
                          full-boot?
@@ -900,7 +901,13 @@ (define* (perform-action action image
 To complete the upgrade, run 'herd restart SERVICE' to stop,
 upgrade, and restart each service that was not automatically restarted.\n")))
                 (return (format #t (G_ "\
-Run 'herd status' to view the list of services on your system.\n"))))))
+Run 'herd status' to view the list of services on your system.\n"))))
+               (mwhen load-for-kexec?
+                 (mlet %store-monad ((kexec? (load-system-for-kexec local-eval
+                                                                    os)))
+                   (mwhen kexec?
+                     (return (info (G_ "system loaded for fast reboot \
+ with 'reboot --kexec'~%"))))))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
@@ -1025,6 +1032,8 @@ (define (show-help)
       --image-size=SIZE  for 'image', produce an image of SIZE"))
   (display (G_ "
       --no-bootloader    for 'init', do not install a bootloader"))
+  (display (G_ "
+      --no-kexec         for 'reconfigure', do not load system for kexec reboot"))
   (display (G_ "
       --volatile         for 'image', make the root file system volatile"))
   (display (G_ "
@@ -1127,6 +1136,9 @@ (define %options
          (option '("no-bootloader" "no-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'install-bootloader? #f result)))
+         (option '("no-kexec") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'load-for-kexec? #f result)))
          (option '("volatile") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'volatile-image-root? #t result)))
@@ -1198,6 +1210,7 @@ (define %default-options
     (image-type . mbr-hybrid-raw)
     (image-size . guess)
     (install-bootloader? . #t)
+    (load-for-kexec? . #t)
     (label . #f)
     (volatile-image-root? . #f)
     (volatile-vm-root? . #t)
@@ -1275,6 +1288,7 @@ (define (process-action action args opts)
                            (leave (G_ "no configuration specified~%")))))))
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
+         (kexec?      (assoc-ref opts 'load-for-kexec?))
          (label       (assoc-ref opts 'label))
          (image-type  (lookup-image-type-by-name
                        (assoc-ref opts 'image-type)))
@@ -1360,6 +1374,7 @@ (define (process-action action args opts)
                                                         (_ #f))
                                                       opts)
                                #:install-bootloader? bootloader?
+                               #:load-for-kexec? kexec?
                                #:target target-file
                                #:gc-root (assoc-ref opts 'gc-root)))))
           #:target target
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index ddb561d28c..e9e16e3422 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -31,6 +31,7 @@ (define-module (guix scripts system reconfigure)
   #:use-module (gnu services herd)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system)
+  #:autoload   (gnu system file-systems) (file-system-device)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix monads)
@@ -52,6 +53,9 @@ (define-module (guix scripts system reconfigure)
             upgrade-services-program
             upgrade-shepherd-services
 
+            kexec-loading-program
+            load-system-for-kexec
+
             install-bootloader-program
             install-bootloader
 
@@ -176,6 +180,27 @@ (define (upgrade-services-program service-files to-start to-unload to-restart)
         (for-each unload-service '#$to-unload)
         (for-each start-service '#$to-start)))))
 
+(define (kexec-loading-program os)
+  "Return a program that calls 'kexec_file_load' to allow rebooting into OS
+via 'kexec'."
+  (let ((root-device (file-system-device
+                      (operating-system-root-file-system os))))
+    (program-file
+     "kexec-load-system.scm"
+     (with-imported-modules '((guix build syscalls))
+       #~(begin
+           (use-modules (guix build syscalls))
+
+           (let ((kernel (open-fdes #$(operating-system-kernel-file os)
+                                    O_RDONLY))
+                 (initrd (open-fdes #$(operating-system-initrd-file os)
+                                    O_RDONLY)))
+             (kexec-load-file kernel initrd
+                              (string-join
+                               (list #$@(operating-system-kernel-arguments
+                                         os root-device)))
+                              KEXEC_FILE_DEBUG)))))))
+
 (define* (upgrade-shepherd-services eval os)
   "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
 upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
@@ -205,6 +230,12 @@ (define* (upgrade-shepherd-services eval os)
                                                             to-unload
                                                             to-restart)))))))
 
+(define (load-system-for-kexec eval os)
+  "Load OS so that it can be rebooted into via kexec, if supported.  Return
+true on success."
+  (eval #~(and (string-contains %host-type "-linux")
+               (primitive-load #$(kexec-loading-program os)))))
+
 \f
 ;;;
 ;;; Bootloader configuration.
-- 
2.46.0