bug#26339: [PATCH v3 1/9] system: Add extlinux support.

[Mathieu Othacehe <m.othacehe@gmail.com>]

* gnu/system.scm (operating-system): Add default bootloader.
  (operating-system-grub.cfg): Use bootloader-configuration-file-generator.
* gnu/system/grub.scm (bootloader-configuration->grub-configuration): New
  variable.
  (grub-configuration-file): Use bootloader-configuration->grub-configuration.
* guix/scripts/system.scm (profile-grub-entries): Rename system->grub-entry to
  system->boot-parameters and adjust accordingly.
  (perform-action): Make bootloader optional. Use
  bootloader-configuration-device.
* gnu/system/bootloader.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |   1 +
 gnu/system.scm            |  11 ++--
 gnu/system/bootloader.scm | 161 ++++++++++++++++++++++++++++++++++++++++++++++
 gnu/system/grub.scm       |  22 ++++---
 guix/scripts/system.scm   |  19 +++---
 5 files changed, 191 insertions(+), 23 deletions(-)
 create mode 100644 gnu/system/bootloader.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index c93dca64c..e2730a466 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -443,6 +443,7 @@ GNU_SYSTEM_MODULES =				\
 						\
   %D%/system.scm				\
   %D%/system/file-systems.scm			\
+  %D%/system/bootloader.scm			\
   %D%/system/grub.scm				\
   %D%/system/install.scm			\
   %D%/system/linux-container.scm		\
diff --git a/gnu/system.scm b/gnu/system.scm
index 189a13262..b947d982d 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -48,7 +48,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
-  #:use-module (gnu system grub)
+  #:use-module (gnu system bootloader)
   #:use-module (gnu system shadow)
   #:use-module (gnu system nss)
   #:use-module (gnu system locale)
@@ -139,8 +139,8 @@ booted from ROOT-DEVICE"
           (default linux-libre))
   (kernel-arguments operating-system-user-kernel-arguments
                     (default '()))                ; list of gexps/strings
-  (bootloader operating-system-bootloader)        ; <grub-configuration>
-
+  (bootloader operating-system-bootloader         ; <bootloader-configuration>
+              (default (extlinux-configuration)))
   (initrd operating-system-initrd                 ; (list fs) -> M derivation
           (default base-initrd))
   (firmware operating-system-firmware             ; list of packages
@@ -754,9 +754,8 @@ populate the \"old entries\" menu."
                            (uuid->string (file-system-device root-fs))
                            (file-system-device root-fs)))
        (entry (operating-system-boot-parameters os system root-device)))
-    (grub-configuration-file (operating-system-bootloader os)
-                             (list entry)
-                              #:old-entries old-entries)))
+    ((bootloader-configuration-file-generator (operating-system-bootloader os))
+     (operating-system-bootloader os) (list entry) #:old-entries old-entries)))
 
 (define (fs->boot-device fs)
   "Given FS, a <file-system> object, return a value suitable for use as the
diff --git a/gnu/system/bootloader.scm b/gnu/system/bootloader.scm
new file mode 100644
index 000000000..ea067bf73
--- /dev/null
+++ b/gnu/system/bootloader.scm
@@ -0,0 +1,161 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 David Craven <david@craven.ch>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system bootloader)
+  #:use-module (gnu system)
+  #:use-module (gnu system grub)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:export (bootloader-configuration
+            bootloader-configuration?
+            bootloader-configuration-bootloader
+            bootloader-configuration-device
+            bootloader-configuration-menu-entries
+            bootloader-configuration-default-entry
+            bootloader-configuration-timeout
+            bootloader-configuration-file-generator
+            bootloader-configuration-file-name
+            bootloader-configuration-installer
+            bootloader-configuration-additional-configuration
+
+            extlinux-configuration
+            grub-configuration
+            grub-efi-configuration
+            syslinux-configuration))
+
+;;; Commentary:
+;;;
+;;; Generic configuration for bootloaders.
+;;;
+;;; Code:
+
+(define-record-type* <bootloader-configuration>
+  bootloader-configuration make-bootloader-configuration
+  bootloader-configuration?
+  (bootloader                      bootloader-configuration-bootloader     ; package
+                                   (default #f))
+  (device                          bootloader-configuration-device         ; string
+                                   (default #f))
+  (menu-entries                    bootloader-configuration-menu-entries   ; list of <boot-parameters>
+                                   (default '()))
+  (default-entry                   bootloader-configuration-default-entry  ; integer
+                                   (default 0))
+  (timeout                         bootloader-configuration-timeout        ; integer
+                                   (default 5))
+  (configuration-file-name         bootloader-configuration-file-name
+                                   (default #f))
+  (configuration-file-generator    bootloader-configuration-file-generator ; procedure
+                                   (default #f))
+  (installer                       bootloader-configuration-installer ; procedure
+                                   (default #f))
+  (additional-configuration        bootloader-configuration-additional-configuration ; record
+                                   (default #f)))
+
+\f
+
+;;;
+;;; Extlinux configuration file.
+;;;
+
+(define* (extlinux-configuration-file config entries
+                                      #:key
+                                      (system (%current-system))
+                                      (old-entries '()))
+  "Return the U-Boot configuration file corresponding to CONFIG, a
+<u-boot-configuration> object, and where the store is available at 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
+    (append entries (bootloader-configuration-menu-entries config)))
+
+  (define (boot-parameters->gexp params)
+    (let ((label (boot-parameters-label params))
+          (kernel (boot-parameters-kernel params))
+          (kernel-arguments (boot-parameters-kernel-arguments params))
+          (initrd (boot-parameters-initrd params)))
+      #~(format port "LABEL ~a
+  MENU LABEL ~a
+  KERNEL ~a
+  FDTDIR ~a/lib/dtbs
+  INITRD ~a
+  APPEND ~a
+~%"
+                #$label #$label
+                #$kernel #$kernel #$initrd
+                (string-join (list #$@kernel-arguments)))))
+
+  (define builder
+    #~(call-with-output-file #$output
+        (lambda (port)
+          (let ((timeout #$(bootloader-configuration-timeout config)))
+            (format port "
+UI menu.c32
+PROMPT ~a
+TIMEOUT ~a~%"
+                    (if (> timeout 0) 1 0)
+                    ;; timeout is expressed in 1/10s of seconds.
+                    (* 10 timeout))
+            #$@(map boot-parameters->gexp all-entries)
+
+            #$@(if (pair? old-entries)
+                   #~((format port "~%")
+                      #$@(map boot-parameters->gexp old-entries)
+                      (format port "~%"))
+                   #~())))))
+
+  (gexp->derivation "extlinux.conf" builder))
+
+
+\f
+
+;;;
+;;; Bootloader configurations.
+;;;
+
+(define* (extlinux-configuration #:optional (config (bootloader-configuration)))
+  (bootloader-configuration
+   (inherit config)
+   (configuration-file-name "/boot/extlinux/extlinux.conf")
+   (configuration-file-generator extlinux-configuration-file)))
+
+(define* (grub-configuration #:optional (config (bootloader-configuration)))
+  (bootloader-configuration
+   (inherit config)
+   (bootloader (@ (gnu packages bootloaders) grub))
+   (configuration-file-name "/boot/grub/grub.cfg")
+   (configuration-file-generator grub-configuration-file)
+   (installer install-grub)
+   (additional-configuration
+    (let ((additional-config (bootloader-configuration-additional-configuration config)))
+      (if additional-config additional-config %default-theme)))))
+
+(define* (grub-efi-configuration #:optional (config (bootloader-configuration)))
+  (bootloader-configuration
+   (inherit (grub-configuration config))
+   (bootloader (@ (gnu packages bootloaders) grub-efi))))
+
+(define* (syslinux-configuration #:optional (config (bootloader-configuration)))
+  (bootloader-configuration
+   (inherit (extlinux-configuration config))
+   (bootloader (@ (gnu packages bootloaders) syslinux))
+   (installer install-syslinux)))
+
+;;; bootloader.scm ends here
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index d2fa984ec..b06336cec 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -27,6 +27,7 @@
   #:use-module (guix download)
   #:use-module (gnu artwork)
   #:use-module (gnu system)
+  #:use-module (gnu system bootloader)
   #:use-module (gnu system file-systems)
   #:autoload   (gnu packages bootloaders) (grub)
   #:autoload   (gnu packages compression) (gzip)
@@ -49,14 +50,6 @@
             %background-image
             %default-theme
 
-            grub-configuration
-            grub-configuration?
-            grub-configuration-device
-            grub-configuration-grub
-
-            menu-entry
-            menu-entry?
-
             grub-configuration-file))
 
 ;;; Commentary:
@@ -277,7 +270,16 @@ code."
    (linux-arguments (boot-parameters-kernel-arguments conf))
    (initrd (boot-parameters-initrd conf))))
 
-(define* (grub-configuration-file config entries
+(define (bootloader-configuration->grub-configuration config)
+  (grub-configuration
+   (grub (bootloader-configuration-bootloader config))
+   (device (bootloader-configuration-device config))
+   (menu-entries (bootloader-configuration-menu-entries config))
+   (default-entry (bootloader-configuration-default-entry config))
+   (timeout (bootloader-configuration-timeout config))
+   (theme (bootloader-configuration-additional-configuration config))))
+
+(define* (grub-configuration-file bootloader-config entries
                                   #:key
                                   (system (%current-system))
                                   (old-entries '()))
@@ -285,6 +287,8 @@ code."
 <grub-configuration> object, and where the store is available at 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 config (bootloader-configuration->grub-configuration bootloader-config))
+
   (define all-entries
     (append (map boot-parameters->menu-entry entries)
             (grub-configuration-menu-entries config)))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 2872bcae6..b96836576 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -38,10 +38,10 @@
   #:use-module (guix build utils)
   #:use-module (gnu build install)
   #:use-module (gnu system)
+  #:use-module (gnu system bootloader)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system linux-container)
   #:use-module (gnu system vm)
-  #:use-module (gnu system grub)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services herd)
@@ -598,8 +598,11 @@ output when building a system derivation, such as a disk image."
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
                                                 #:mappings mappings))
-       (grub      (package->derivation (grub-configuration-grub
-                                        (operating-system-bootloader os))))
+       (bootloader (let ((bootloader (bootloader-configuration-bootloader
+                                      (operating-system-bootloader os))))
+                     (if bootloader
+                         (package->derivation bootloader)
+                         (return #f))))
        (grub.cfg  (if (eq? 'container action)
                       (return #f)
                       (operating-system-bootcfg os
@@ -611,8 +614,8 @@ output when building a system derivation, such as a disk image."
        ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
        ;; root.  See <http://bugs.gnu.org/21068>.
        (drvs   -> (if (memq action '(init reconfigure))
-                      (if bootloader?
-                          (list sys grub.cfg grub)
+                      (if (and bootloader? bootloader)
+                          (list sys grub.cfg bootloader)
                           (list sys grub.cfg))
                       (list sys)))
        (%         (if derivations-only?
@@ -628,8 +631,8 @@ output when building a system derivation, such as a disk image."
                     drvs)
 
           ;; Make sure GRUB is accessible.
-          (when bootloader?
-            (let ((prefix (derivation->output-path grub)))
+          (when (and bootloader? bootloader)
+            (let ((prefix (derivation->output-path bootloader)))
               (setenv "PATH"
                       (string-append  prefix "/bin:" prefix "/sbin:"
                                       (getenv "PATH")))))
@@ -832,7 +835,7 @@ resulting from command-line parsing."
                         ((first second) second)
                         (_ #f)))
          (device      (and bootloader?
-                           (grub-configuration-device
+                           (bootloader-configuration-device
                             (operating-system-bootloader os)))))
 
     (with-store store
-- 
2.12.2