From 8b22107e5d0bdeb300fb33b5a40aed2057a66b94 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Mon, 29 May 2017 14:24:20 +0200
Subject: [PATCH] bootloader: Use menu-entry to define custom bootloader
 entries.

* gnu/bootloader.scm (<menu-entry>): New variable. Export associated getters,
This record is extracted from grub module.
* gnu/bootloader/extlinux.scm (extlinux-configuration-file): Use
  menu-entry->boot-parameters to convert menu-entry records to
  boot-parameters.
* gnu/bootloader/grub.scm (<menu-entry>): Remove.
(boot-parameters->menu-entry): Remove.
(grub-configuration-file): Use boot-parameters to create configuration
entries.
* gnu/system.scm (menu-entry->boot-parameters): New exported procedure.
---
 gnu/bootloader.scm          | 26 ++++++++++++-
 gnu/bootloader/extlinux.scm |  3 +-
 gnu/bootloader/grub.scm     | 75 ++++++++++++++-----------------------
 gnu/system.scm              | 14 +++++++
 4 files changed, 70 insertions(+), 48 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 4e77974d31..d5fcf30f05 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -23,7 +23,15 @@
   #:use-module (guix records)
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
-  #:export (bootloader
+  #:export (menu-entry
+            menu-entry?
+            menu-entry-label
+            menu-entry-device
+            menu-entry-linux
+            menu-entry-linux-arguments
+            menu-entry-initrd
+
+            bootloader
             bootloader?
             bootloader-name
             bootloader-package
@@ -48,6 +56,22 @@
             %bootloaders
             lookup-bootloader-by-name))
 
+
+;;;
+;;; Menu-entry record.
+;;;
+
+(define-record-type* <menu-entry>
+  menu-entry make-menu-entry
+  menu-entry?
+  (label           menu-entry-label)
+  (device          menu-entry-device       ; file system uuid, label, or #f
+                   (default #f))
+  (linux           menu-entry-linux)
+  (linux-arguments menu-entry-linux-arguments
+                   (default '()))          ; list of string-valued gexps
+  (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp
+
 
 ;;;
 ;;; Bootloader record.
diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm
index 67b8815d40..0a1263aed7 100644
--- a/gnu/bootloader/extlinux.scm
+++ b/gnu/bootloader/extlinux.scm
@@ -37,7 +37,8 @@
 corresponding to old generations of the system."
 
   (define all-entries
-    (append entries (bootloader-configuration-menu-entries config)))
+    (append entries (map menu-entry->boot-parameters
+                         (bootloader-configuration-menu-entries config))))
 
   (define (boot-parameters->gexp params)
     (let ((label (boot-parameters-label params))
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 49616b7164..f1cc3324db 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -66,12 +66,15 @@
 (define (strip-mount-point mount-point file)
   "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
 denoting a file name."
-  (if (string=? mount-point "/")
-      file
-      #~(let ((file #$file))
-          (if (string-prefix? #$mount-point file)
-              (substring #$file #$(string-length mount-point))
-              file))))
+  (match mount-point
+    ((? string? mount-point)
+     (if (string=? mount-point "/")
+         file
+         #~(let ((file #$file))
+             (if (string-prefix? #$mount-point file)
+                 (substring #$file #$(string-length mount-point))
+                 file))))
+    (#f file)))
 
 (define-record-type* <grub-image>
   grub-image make-grub-image
@@ -103,19 +106,6 @@ denoting a file name."
    (color-highlight '((fg . yellow) (bg . black)))
    (color-normal    '((fg . light-gray) (bg . black))))) ;XXX: #x303030
 
-(define-record-type* <menu-entry>
-  menu-entry make-menu-entry
-  menu-entry?
-  (label           menu-entry-label)
-  (device          menu-entry-device       ; file system uuid, label, or #f
-                   (default #f))
-  (device-mount-point menu-entry-device-mount-point
-                      (default "/"))
-  (linux           menu-entry-linux)
-  (linux-arguments menu-entry-linux-arguments
-                   (default '()))          ; list of string-valued gexps
-  (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp
-
 
 ;;;
 ;;; Background image & themes.
@@ -312,16 +302,6 @@ code."
         (#f
          #~(format #f "search --file --set ~a" #$file)))))
 
-(define (boot-parameters->menu-entry conf)
-  "Convert a <boot-parameters> instance to a corresponding <menu-entry>."
-  (menu-entry
-   (label (boot-parameters-label conf))
-   (device (boot-parameters-store-device conf))
-   (device-mount-point (boot-parameters-store-mount-point conf))
-   (linux (boot-parameters-kernel conf))
-   (linux-arguments (boot-parameters-kernel-arguments conf))
-   (initrd (boot-parameters-initrd conf))))
-
 (define* (grub-configuration-file config entries
                                   #:key
                                   (system (%current-system))
@@ -331,33 +311,36 @@ code."
 STORE-FS, a <file-system> object.  OLD-ENTRIES is taken to be a list of menu
 entries corresponding to old generations of the system."
   (define all-entries
-    (map boot-parameters->menu-entry
-         (append entries
-                 (bootloader-configuration-menu-entries config))))
+    (append entries (map menu-entry->boot-parameters
+                         (bootloader-configuration-menu-entries config))))
 
-  (define entry->gexp
-    (match-lambda
-     (($ <menu-entry> label device device-mount-point
-                      linux arguments initrd)
+  (define (boot-parameters->gexp params)
+    (let ((device (boot-parameters-store-device params))
+          (device-mount-point (boot-parameters-store-mount-point params))
+          (label (boot-parameters-label params))
+          (kernel (boot-parameters-kernel params))
+          (arguments (boot-parameters-kernel-arguments params))
+          (initrd (boot-parameters-initrd params)))
       ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-      ;; Use the right file names for LINUX and INITRD in case
+      ;; Use the right file names for KERNEL and INITRD in case
       ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
       ;; separate partition.
-      (let ((linux  (strip-mount-point device-mount-point linux))
-            (initrd (strip-mount-point device-mount-point initrd)))
+      (let ((kernel  (strip-mount-point device-mount-point kernel))
+            (initrd  (strip-mount-point device-mount-point initrd)))
         #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
                   #$label
-                  #$(grub-root-search device linux)
-                  #$linux (string-join (list #$@arguments))
-                  #$initrd)))))
+                  #$(grub-root-search device kernel)
+                  #$kernel (string-join (list #$@arguments))
+                  #$initrd))))
 
   (mlet %store-monad ((sugar (eye-candy config
-                                        (menu-entry-device (first all-entries))
-                                        (menu-entry-device-mount-point
+                                        (boot-parameters-store-device
+                                         (first all-entries))
+                                        (boot-parameters-store-mount-point
                                          (first all-entries))
                                         #:system system
                                         #:port #~port)))
@@ -374,12 +357,12 @@ set default=~a
 set timeout=~a~%"
                     #$(bootloader-configuration-default-entry config)
                     #$(bootloader-configuration-timeout config))
-            #$@(map entry->gexp all-entries)
+            #$@(map boot-parameters->gexp all-entries)
 
             #$@(if (pair? old-entries)
                    #~((format port "
 submenu \"GNU system, old configurations...\" {~%")
-                      #$@(map entry->gexp (map boot-parameters->menu-entry old-entries))
+                      #$@(map boot-parameters->gexp old-entries)
                       (format port "}~%"))
                    #~()))))
 
diff --git a/gnu/system.scm b/gnu/system.scm
index 0076f2fcb1..674c6f85be 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -112,6 +112,7 @@
             boot-parameters-initrd
             read-boot-parameters
             read-boot-parameters-file
+            menu-entry->boot-parameters
 
             local-host-aliases
             %setuid-programs
@@ -299,6 +300,19 @@ The object has its kernel-arguments extended in order to make it bootable."
                                                      system
                                                      root-device)))
       #f)))
+
+(define (menu-entry->boot-parameters menu-entry)
+  "Convert a <menu-entry> instance to a corresponding <boot-parameters>."
+  (boot-parameters
+   (label (menu-entry-label menu-entry))
+   (root-device #f)
+   (boot-name 'custom)
+   (store-device #f)
+   (store-mount-point #f)
+   (kernel (menu-entry-linux menu-entry))
+   (kernel-arguments (menu-entry-linux-arguments menu-entry))
+   (initrd (menu-entry-initrd menu-entry))))
+
 
 ;;;
 ;;; Services.