Subject: [bug#41011] [PATCH] gnu: grub: Support for network boot via tftp/nfs.

From: Stefan <[email-masked]>
Date: Sat, 6 Jun 2020 15:33:26 +0200

* gnu/bootloader/grub.scm (grub-efi-net-bootloader): New efi bootloader for
network booting via tftp/nfs.
(install-grub-efi-net): New bootloader installer for tftp.
(grub-root-search): Adding support for tftp root.
(eye-candy): Use 'gfxterm' for all systems if selected via 'terminal-outputs'.
* gnu/system.scm (read-boot-parameters): Prevent devices with ":/" from being
treated as a file system label.
* gnu/build/linux-boot.scm (device-string->file-system-device): Prevent devices
with ":/" from being treated as a file system label.
---
 gnu/bootloader/grub.scm  | 127 +++++++++++++++++++++++++++------------
 gnu/build/linux-boot.scm |   1 +
 gnu/system.scm           |   3 +-
 3 files changed, 93 insertions(+), 38 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 2d9a39afc3..60b3a12037 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -23,7 +23,7 @@
 
 (define-module (gnu bootloader grub)
   #:use-module (guix records)
-  #:use-module ((guix utils) #:select (%current-system))
+  #:use-module ((guix utils) #:select (%current-system %current-target-system))
   #:use-module (guix gexp)
   #:use-module (gnu artwork)
   #:use-module (gnu bootloader)
@@ -47,6 +47,8 @@
 
             grub-bootloader
             grub-efi-bootloader
+            make-grub-efi-net-bootloader
+            grub-efi-net-bootloader
             grub-mkrescue-bootloader
             grub-minimal-bootloader
 
@@ -135,41 +137,25 @@ file with the resolution provided in CONFIG."
            (_ #f)))))
 
 (define* (eye-candy config store-device store-mount-point
-                    #:key store-directory-prefix system port)
+                    #:key store-directory-prefix port)
   "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
 concerned with graphics mode, background images, colors, and all that.
 STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
 its mount point; these are used to determine where the background image and
-fonts must be searched for.  SYSTEM must be the target system string---e.g.,
-\"x86_64-linux\".  STORE-DIRECTORY-PREFIX is a directory prefix to prepend to
-any store file name."
-  (define setup-gfxterm-body
-    (let ((gfxmode
-           (or (and-let* ((theme (bootloader-configuration-theme config))
-                          (gfxmode (grub-theme-gfxmode theme)))
-                 (string-join gfxmode ";"))
-               "auto")))
-
-      ;; Intel and EFI systems need to be switched into graphics mode, whereas
-      ;; most other modern architectures have no other mode and therefore
-      ;; don't need to be switched.
-
-      ;; XXX: Do we really need to restrict to x86 systems?  We could imitate
-      ;; what the GRUB default configuration does and decide based on whether
-      ;; a user provided 'gfxterm' in the terminal-outputs field of their
-      ;; bootloader-configuration record.
-      (if (string-match "^(x86_64|i[3-6]86)-" system)
-          (format #f "
-  set gfxmode=~a
-  insmod all_video
-  insmod gfxterm~%" gfxmode)
-          "")))
-
+fonts must be searched for.  STORE-DIRECTORY-PREFIX is a directory prefix to
+prepend to any store file name."
   (define (setup-gfxterm config font-file)
     (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
-        #~(format #f "if loadfont ~a; then
-  setup_gfxterm
-fi~%" #+font-file)
+        #~(format #f "
+if loadfont ~a; then
+  set gfxmode=~a
+  insmod all_video
+  insmod gfxterm
+fi~%"
+                  #$font-file
+                  #$(string-join
+                      (grub-theme-gfxmode (bootloader-theme config))
+                      ";"))
         ""))
 
   (define (theme-colors type)
@@ -190,8 +176,6 @@ fi~%" #+font-file)
 
   (and image
        #~(format #$port "
-function setup_gfxterm {~a}
-
 # Set 'root' to the partition that contains /gnu/store.
 ~a
 
@@ -206,7 +190,6 @@ else
   set menu_color_normal=cyan/blue
   set menu_color_highlight=white/blue
 fi~%"
-                 #$setup-gfxterm-body
                  #$(grub-root-search store-device font-file)
                  #$(setup-gfxterm config font-file)
                  #$(grub-setup-io config)
@@ -313,6 +296,9 @@ code."
         ((? file-system-label? label)
          (format #f "search --label --set ~a"
                  (file-system-label->string label)))
+        ((? (lambda (device)
+              (and (string? device) (string-contains device ":/"))) nfs-uri)
+         "set root=(tftp)")
         ((or #f (? string?))
          #~(format #f "search --file --set ~a" #$file)))))
 
@@ -358,7 +344,6 @@ when booting a root file system on a Btrfs subvolume."
                (menu-entry-device (first all-entries))
                (menu-entry-device-mount-point (first all-entries))
                #:store-directory-prefix store-directory-prefix
-               #:system system
                #:port #~port))
 
   (define keyboard-layout-config
@@ -498,11 +483,73 @@ fi~%"))))
                       "--bootloader-id=Guix"
                       "--efi-directory" target-esp))))
 
+(define (install-grub-efi-net subdir)
+  "Define a grub-efi bootloader installer for installation in SUBDIR,
+which is usually \"efi/boot\" or \"efi/Guix\"."
+  (let* ((arch (car (string-split (or (%current-target-system)
+                                      (%current-system))
+                                  #\-)))
+         (efi-bootloader-link (string-append "/boot"
+                                             (match arch
+                                               ("i686" "ia32")
+                                               ("x86_64" "x64")
+                                               ("arm" "arm")
+                                               ("armhf" "arm")
+                                               ("aarch64" "aa64")
+                                               ("riscv" "riscv32")
+                                               ("riscv64" "riscv64"))
+                                             ".efi"))
+         (efi-bootloader (string-append (match arch
+                                          ("i686" "i386")
+                                          ("x86_64" "x86_64")
+                                          ("arm" "arm")
+                                          ("armhf" "arm")
+                                          ("aarch64" "arm64")
+                                          ("riscv" "riscv32")
+                                          ("riscv64" "riscv64"))
+                                        "-efi/core.efi")))
+    #~(lambda (bootloader target mount-point)
+        "Install GRUB as e.g. \"bootx64.efi\" or \"bootarm64.efi\" \"into
+SUBDIR, which is usually \"efi/boot\" or \"efi/Guix\" below the directory TARGET
+for the system whose root is mounted at MOUNT-POINT."
+        (let* (;; Use target-depth and subdir-depth to construct links to
+               ;; "../gnu" and "../../../boot/grub/grub.cfg" with the correct
+               ;; number of "../". Note: This doesn't consider ".." or ".",
+               ;; which may appear inside target or subdir.
+               (target-depth (length (delete "" (string-split target #\/))))
+               (subdir-depth (length (delete "" (string-split #$subdir #\/))))
+               (up1 (string-join (make-list target-depth "..") "/" 'suffix))
+               (up2 (string-join (make-list subdir-depth "..") "/" 'suffix))
+               (net-dir (string-append mount-point target "/"))
+               (store-name (car (delete "" (string-split bootloader #\/))))
+               (store (string-append up1 store-name))
+               (store-link (string-append net-dir store-name))
+               (grub-cfg (string-append up1 up2 "boot/grub/grub.cfg"))
+               (grub-cfg-link (string-append net-dir #$subdir "/grub.cfg"))
+               (efi-bootloader-link
+                (string-append net-dir #$subdir #$efi-bootloader-link)))
+          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
+          ;; root partition.
+          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+          (invoke/quiet (string-append bootloader "/bin/grub-mknetdir")
+                        (string-append "--net-directory=" net-dir)
+                        (string-append "--subdir=" #$subdir))
+          (false-if-exception (delete-file store-link))
+          (symlink store store-link)
+          (false-if-exception (delete-file grub-cfg-link))
+          (symlink grub-cfg grub-cfg-link)
+          (false-if-exception (delete-file efi-bootloader-link))
+          (symlink #$efi-bootloader efi-bootloader-link)))))
+
 ^L
 
 ;;;
 ;;; Bootloader definitions.
 ;;;
+;;; For all these grub-bootloader variables the path to /boot/grub/grub.cfg
+;;; is fixed.  Inheriting and overwriting the field 'configuration-file' will
+;;; break 'guix system delete-generations', 'guix system switch-generation',
+;;; and 'guix system roll-back'.
 
 (define grub-bootloader
   (bootloader
@@ -513,12 +560,12 @@ fi~%"))))
    (configuration-file "/boot/grub/grub.cfg")
    (configuration-file-generator grub-configuration-file)))
 
-(define* grub-minimal-bootloader
+(define grub-minimal-bootloader
   (bootloader
    (inherit grub-bootloader)
    (package grub-minimal)))
 
-(define* grub-efi-bootloader
+(define grub-efi-bootloader
   (bootloader
    (inherit grub-bootloader)
    (installer install-grub-efi)
@@ -526,7 +573,13 @@ fi~%"))))
    (name 'grub-efi)
    (package grub-efi)))
 
-(define* grub-mkrescue-bootloader
+(define grub-efi-net-bootloader
+  (bootloader
+   (inherit grub-efi-bootloader)
+   (name 'grub-efi-net-bootloader)
+   (installer (install-grub-efi-net "efi/boot"))))
+
+(define grub-mkrescue-bootloader
   (bootloader
    (inherit grub-efi-bootloader)
    (package grub-hybrid)))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index f08bb11514..3a79cfd461 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -503,6 +503,7 @@ upon error."
     ;; string, but the string can represent a device, a UUID, or a
     ;; label.  So check for all three.
     (cond ((string-prefix? "/" device-string) device-string)
+          ((string-contains device-string ":/") device-string)
           ((uuid device-string) => identity)
           (else (file-system-label device-string))))
 
diff --git a/gnu/system.scm b/gnu/system.scm
index ac8bbd1d16..91caba7012 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -301,7 +301,8 @@ file system labels."
       ((? string? device)
        ;; It used to be that we would not distinguish between labels and
        ;; device names.  Try to infer the right thing here.
-       (if (string-prefix? "/dev/" device)
+       (if (or (string-prefix? "/dev/" device)
+               (string-contains device ":/")) ; nfs
            device
            (file-system-label device)))))
 
-- 
2.26.0