bug#26339: [PATCH v2 02/12] 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.
* tests/system.scm: Adjust operating-system to new API.
* tests/guix-system.sh: Adjust operating-system to new API.
---
 gnu/local.mk              |   1 +
 gnu/system.scm            |  10 +--
 gnu/system/bootloader.scm | 161 ++++++++++++++++++++++++++++++++++++++++++++++
 gnu/system/grub.scm       |  22 ++++---
 guix/scripts/system.scm   |  44 ++++++-------
 tests/guix-system.sh      |   2 -
 tests/system.scm          |   2 -
 7 files changed, 200 insertions(+), 42 deletions(-)
 create mode 100644 gnu/system/bootloader.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index cf9f5c719..8ba2e4721 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -439,6 +439,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 7c66f6088..ce0a4a00e 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)
@@ -131,8 +131,8 @@
           (default linux-libre))
   (kernel-arguments operating-system-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
@@ -759,8 +759,8 @@ populate the \"old entries\" menu."
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
                            (initrd initrd)))))
-    (grub-configuration-file (operating-system-bootloader os) entries
-                             #:old-entries old-entries)))
+    ((bootloader-configuration-file-generator (operating-system-bootloader os))
+     (operating-system-bootloader os) entries #: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 f2838d633..0b52e3e7e 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:
@@ -276,7 +269,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 '()))
@@ -284,6 +286,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 9ffdc15ab..3ec100032 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)
@@ -385,32 +385,25 @@ NUMBERS, which is a list of generation numbers."
                                   (numbers (generation-numbers profile)))
   "Return a list of 'menu-entry' for the generations of PROFILE specified by
 NUMBERS, which is a list of generation numbers."
-  (define (system->grub-entry system number time)
+  (define (system->boot-parameters system number time)
     (unless-file-not-found
      (let* ((file             (string-append system "/parameters"))
             (params           (call-with-input-file file
                                 read-boot-parameters))
-            (label            (boot-parameters-label params))
             (root             (boot-parameters-root-device params))
             (root-device      (if (bytevector? root)
                                   (uuid->string root)
-                                  root))
-            (kernel           (boot-parameters-kernel params))
-            (kernel-arguments (boot-parameters-kernel-arguments params))
-            (initrd           (boot-parameters-initrd params)))
-       (menu-entry
-        (label (string-append label " (#"
+                                  root)))
+       (boot-parameters
+        (inherit params)
+        (label (string-append (boot-parameters-label params) " (#"
                               (number->string number) ", "
                               (seconds->string time) ")"))
-        (device (boot-parameters-store-device params))
-        (device-mount-point (boot-parameters-store-mount-point params))
-        (linux kernel)
-        (linux-arguments
-         (cons* (string-append "--root=" root-device)
+        (kernel-arguments
+         (cons* (string-append "--root=" (boot-parameters-root-device params))
                 (string-append "--system=" system)
                 (string-append "--load=" system "/boot")
-                kernel-arguments))
-        (initrd initrd)))))
+                (boot-parameters-kernel-arguments params)))))))
 
   (let* ((systems (map (cut generation-file-name profile <>)
                        numbers))
@@ -418,7 +411,7 @@ NUMBERS, which is a list of generation numbers."
                          (unless-file-not-found
                           (stat:mtime (lstat system))))
                        systems)))
-    (filter-map system->grub-entry systems numbers times)))
+    (filter-map system->boot-parameters systems numbers times)))
 
 \f
 ;;;
@@ -636,8 +629,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
@@ -649,8 +645,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?
@@ -666,8 +662,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")))))
@@ -870,7 +866,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
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index de6db0928..525480a11 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -91,7 +91,6 @@ OS_BASE='
   (timezone "Europe/Paris")
   (locale "en_US.UTF-8")
 
-  (bootloader (grub-configuration (device "/dev/sdX")))
   (file-systems (cons (file-system
                         (device "root")
                         (title (string->symbol "label"))
@@ -162,7 +161,6 @@ make_user_config ()
   (timezone "Europe/Paris")
   (locale "en_US.UTF-8")
 
-  (bootloader (grub-configuration (device "/dev/sdX")))
   (file-systems (cons (file-system
                         (device "root")
                         (title 'label)
diff --git a/tests/system.scm b/tests/system.scm
index ca34409be..bdda08e18 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -36,7 +36,6 @@
     (host-name "komputilo")
     (timezone "Europe/Berlin")
     (locale "en_US.utf8")
-    (bootloader (grub-configuration (device "/dev/sdX")))
     (file-systems (cons %root-fs %base-file-systems))
 
     (users %base-user-accounts)))
@@ -51,7 +50,6 @@
     (host-name "komputilo")
     (timezone "Europe/Berlin")
     (locale "en_US.utf8")
-    (bootloader (grub-configuration (device "/dev/sdX")))
     (mapped-devices (list %luks-device))
     (file-systems (cons (file-system
                           (inherit %root-fs)
-- 
2.12.2