03/18: bootloader: grub: Remove hardcoded partition number for the Hurd.

[guix-commits]

janneke pushed a commit to branch master
in repository guix.

commit fdb23d9db8ca5431e280366c5c834e01eda62a5f
Author: Janneke Nieuwenhuizen <janneke@gnu.org>
AuthorDate: Thu Oct 24 21:22:39 2024 +0200

    bootloader: grub: Remove hardcoded partition number for the Hurd.
    
    This supports using another than the default DISK0 PART1 and using LABEL or
    UUID as root file-system specifier.  It still defaults to DISK0 PART1 if
    the file-system cannot be found, i.e., lives only at the build side: A
    virtual machine/childhurd build.
    
    * gnu/build/file-systems.scm (%hurd-device-spec-regexp, 
%device-spec-regexp):
    New variables.
    (device-name->hurd-device-name, hurd-device-name->device-name,
    device-spec->device, device-spec->device-name): Use them in new procedures.
    * gnu/bootloader/grub.scm (make-grub-configuration): Use them to remove
    hardcoded partition number (root-index 1).
    
    Change-Id: I49fa93dacc09883dfb4d695402c5eac2e0e17286
---
 gnu/bootloader/grub.scm    | 19 ++++++++++-----
 gnu/build/file-systems.scm | 58 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+), 6 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 2723eda5f4..ef516b1e13 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019, 2020, 2023, 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
@@ -34,6 +34,7 @@
   #:use-module (guix gexp)
   #:use-module (gnu artwork)
   #:use-module (gnu bootloader)
+  #:use-module (gnu build file-systems)
   #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system keyboard)
@@ -45,6 +46,7 @@
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
   #:export (grub-theme
             grub-theme?
             grub-theme-image
@@ -355,6 +357,11 @@ code."
         ((or #f (? string?))
          #~(format #f "search --file --set ~a" #$file)))))
 
+(define* (device->hurd-device-name device-spec #:key (disk "w"))
+  "Return DEVICE as a Hurd name spec: part:PART-NUMBER:device:DISKdDISK-INDEX."
+  (let ((device-name (canonicalize-device-spec device-spec)))
+    (device-name->hurd-device-name device-name #:disk disk)))
+
 (define* (make-grub-configuration grub config entries
                                   #:key
                                   (locale #f)
@@ -413,16 +420,16 @@ when booting a root file system on a Btrfs subvolume."
                ;; IDE driver ("hdX") and those understood by rumpdisk ("wdX"
                ;; in the "noide" case).
                (disk (if (member "noide" arguments) "w" "h"))
-               (modules (menu-entry-multiboot-modules entry))
-               (root-index 1))          ; XXX EFI will need root-index 2
+               (device-spec (and=> device file-system-device->string))
+               (device-name (and=> device-spec device-spec->device-name))
+               (modules (menu-entry-multiboot-modules entry)))
           #~(format port "
 menuentry ~s {
-  multiboot ~a root=part:~a:device:~ad0~a~a
+  multiboot ~a root=~a~a~a
 }~%"
                     #$label
                     #$kernel
-                    #$root-index
-                    #$disk
+                    #$(device-name->hurd-device-name device-name #:disk disk)
                     (string-join (list #$@arguments) " " 'prefix)
                     (string-join (map string-join '#$modules)
                                  "\n  module " 'prefix))))
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 41e1c9e282..6fd9f95093 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -53,6 +54,11 @@
             find-partition-by-luks-uuid
             canonicalize-device-spec
 
+            device-name->hurd-device-name
+            device-spec->device
+            device-spec->device-name
+            hurd-device-name->device-name
+
             read-partition-label
             read-partition-uuid
             read-luks-partition-uuid
@@ -1431,4 +1437,56 @@ corresponds to the symbols listed in FLAGS."
         (or (file-system-mount-may-fail? fs)
             (apply throw args))))))
 
+(define %device-name-regexp "/dev/[hsvw]d([abcd])([0-9]*)")
+(define %hurd-device-name-regexp "part:([0-9]*):device:[hw]d([0-9]*)")
+
+(define (device-spec->device-name device-spec)
+  "Return DEVICE-SPEC as a Linux /dev/XdYZ device name, also catering for uuid
+or label."
+  (cond ((string-match %device-name-regexp device-spec)
+         device-spec)
+        ((string-match %hurd-device-name-regexp device-spec)
+         (hurd-device-name->device-name device-spec))
+        ((string->uuid device-spec)
+         =>
+         (lambda (uuid) (false-if-exception (find-partition-by-uuid uuid))))
+        (else
+         (false-if-exception (find-partition-by-label device-spec)))))
+
+(define* (device-name->hurd-device-name device-name #:key (disk "w"))
+  "Return DEVICE-NAME as a Hurd device name:
+     part:PART-NUMBER:device:DISKdDISK-INDEX
+Default to part:1:device:DISKd0 if partition cannot be found."
+  (let* ((m (and=> device-name (cute string-match %device-name-regexp <>)))
+         (disk-char (and m (and=> (match:substring m 1)
+                                  (compose car string->list))))
+         (disk-index (or (and disk-char
+                              (- (char->integer disk-char) (char->integer 
#\a)))
+                         0))
+         (partition-number (or (and m (and=> (match:substring m 2)
+                                             string->number))
+                               1)))
+    (format #f "part:~a:device:~ad~a" partition-number disk disk-index)))
+
+(define* (hurd-device-name->device-name device-name #:key (disk "s"))
+  (let* ((m (and=> device-name (cute string-match %hurd-device-name-regexp 
<>)))
+         (disk-index-string (and=> m (cute match:substring <> 2)))
+         (disk-index (or (and=> disk-index-string string->number)
+                         0))
+         (disk-index-char (integer->char (+ disk-index (char->integer #\a))))
+         (partition-string (and=> m (cute match:substring <> 1)))
+         (partition-number (or (and=> partition-string string->number)
+                               1)))
+    (format #f "/dev/~ad~a~a" disk disk-index-char partition-number)))
+
+(define (device-spec->device device-spec)
+  "Return DEVICE-SPEC as UUID, FILE-SYSTEM-LABEL, or DEVICE-SPEC."
+  (cond ((and=> (string->uuid device-spec)
+                find-partition-by-uuid)
+         (string->uuid device-spec))
+        ((find-partition-by-label device-spec)
+         (file-system-label device-spec))
+        (else
+         device-spec)))
+
 ;;; file-systems.scm ends here