bootloader: Add extlinux support.

* gnu/bootloader.scm: New file.
* gnu/bootloader/extlinux.scm: New file.
* gnu/bootloader/grub.scm: New file.
* gnu/local.mk: Build new files.
* gnu/system.scm: Adapt to new bootloader api.
* gnu/scripts/system.scm: Adapt to new bootloader api.
* gnu.scm: Remove (gnu system grub) and replace by (gnu bootloader) and (gnu
bootloader grub) modules.
* gnu/system/grub.scm: Moved content to gnu/bootloader/grub.scm.
* gnu/system/vm: Replace (gnu system grub) module by (gnu bootloader).
* gnu/tests.scm: Ditto.
* gnu/tests/nfs.scm: Ditto.

8 files changed, 354 insertions, 59 deletions

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
new file mode 100644
index 0000000000..4e77974d31
--- /dev/null
+++ b/gnu/bootloader.scm
@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;;
+;;; 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 bootloader)
+  #:use-module (guix discovery)
+  #:use-module (guix records)
+  #:use-module (guix ui)
+  #:use-module (srfi srfi-1)
+  #:export (bootloader
+            bootloader?
+            bootloader-name
+            bootloader-package
+            bootloader-installer
+            bootloader-configuration-file
+            bootloader-configuration-file-generator
+
+            bootloader-configuration
+            bootloader-configuration?
+            bootloader-configuration-bootloader
+            bootloader-configuration-device
+            bootloader-configuration-menu-entries
+            bootloader-configuration-default-entry
+            bootloader-configuration-timeout
+            bootloader-configuration-theme
+            bootloader-configuration-terminal-outputs
+            bootloader-configuration-terminal-inputs
+            bootloader-configuration-serial-unit
+            bootloader-configuration-serial-speed
+            bootloader-configuration-additional-configuration
+
+            %bootloaders
+            lookup-bootloader-by-name))
+
+
+;;;
+;;; Bootloader record.
+;;;
+
+;; The <bootloader> record contains fields expressing how the bootloader
+;; should be installed. Every bootloader in gnu/bootloader/ directory
+;; has to be described by this record.
+
+(define-record-type* <bootloader>
+  bootloader make-bootloader
+  bootloader?
+  (name                            bootloader-name)
+  (package                         bootloader-package)
+  (installer                       bootloader-installer)
+  (configuration-file              bootloader-configuration-file)
+  (configuration-file-generator    bootloader-configuration-file-generator))
+
+
+;;;
+;;; Bootloader configuration record.
+;;;
+
+;; The <bootloader-configuration> record contains bootloader independant
+;; configuration used to fill bootloader configuration file.
+
+(define-record-type* <bootloader-configuration>
+  bootloader-configuration make-bootloader-configuration
+  bootloader-configuration?
+  (bootloader                      bootloader-configuration-bootloader)    ; <bootloader>
+  (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        ; seconds as integer
+                                   (default 5))
+  (theme                           bootloader-configuration-theme          ; bootloader-specific theme
+                                   (default #f))
+  (terminal-outputs                bootloader-configuration-terminal-outputs ; list of symbols
+                                   (default '(gfxterm)))
+  (terminal-inputs                 bootloader-configuration-terminal-inputs  ; list of symbols
+                                   (default '()))
+  (serial-unit                     bootloader-configuration-serial-unit      ; integer | #f
+                                   (default #f))
+  (serial-speed                    bootloader-configuration-serial-speed     ; integer | #f
+                                   (default #f))
+  (additional-configuration        bootloader-configuration-additional-configuration ; record
+                                   (default #f)))
+
+
+;;;
+;;; Bootloaders.
+;;;
+
+(define (bootloader-modules)
+  "Return the list of bootloader modules."
+  (all-modules (map (lambda (entry)
+                      `(,entry . "gnu/bootloader"))
+                    %load-path)))
+
+(define %bootloaders
+  ;; The list of publically-known bootloaders.
+  (delay (fold-module-public-variables (lambda (obj result)
+                                         (if (bootloader? obj)
+                                             (cons obj result)
+                                             result))
+                                       '()
+                                       (bootloader-modules))))
+
+(define (lookup-bootloader-by-name name)
+  "Return the bootloader called NAME."
+  (or (find (lambda (bootloader)
+              (eq? name (bootloader-name bootloader)))
+            (force %bootloaders))
+      (leave (G_ "~a: no such bootloader~%") name)))
diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm
new file mode 100644
index 0000000000..a002001071
--- /dev/null
+++ b/gnu/bootloader/extlinux.scm
@@ -0,0 +1,123 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; 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 bootloader extlinux)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu system)
+  #:use-module (gnu packages bootloaders)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:export (extlinux-bootloader
+            syslinux-bootloader
+
+            extlinux-configuration
+            syslinux-configuration))
+
+(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))
+
+
+
+
+;;;
+;;; Install procedures.
+;;;
+
+(define dd
+  #~(lambda (bs count if of)
+      (zero? (system* "dd"
+                      (string-append "bs=" (number->string bs))
+                      (string-append "count=" (number->string count))
+                      (string-append "if=" if)
+                      (string-append "of=" of)))))
+
+(define install-extlinux
+  #~(lambda (bootloader device mount-point)
+      (let ((extlinux (string-append bootloader "/sbin/extlinux"))
+            (install-dir (string-append mount-point "/boot/extlinux"))
+            (syslinux-dir (string-append bootloader "/share/syslinux")))
+        (for-each (lambda (file)
+                    (install-file file install-dir))
+                  (find-files syslinux-dir "\\.c32$"))
+
+        (unless (and (zero? (system* extlinux "--install" install-dir))
+                     (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device))
+          (error "failed to install SYSLINUX")))))
+
+
+
+;;;
+;;; Bootloader definitions.
+;;;
+
+(define extlinux-bootloader
+  (bootloader
+   (name 'extlinux)
+   (package syslinux)
+   (installer install-extlinux)
+   (configuration-file "/boot/extlinux/extlinux.conf")
+   (configuration-file-generator extlinux-configuration-file)))
diff --git a/gnu/system/grub.scm b/gnu/bootloader/grub.scm
index 85878de85c..49616b7164 100644
--- a/gnu/system/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,7 +19,7 @@
 ;;; 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 grub)
+(define-module (gnu bootloader grub)
   #:use-module (guix store)
   #:use-module (guix packages)
   #:use-module (guix derivations)
@@ -28,6 +29,7 @@
   #:use-module (guix download)
   #:use-module (gnu artwork)
   #:use-module (gnu system)
+  #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
   #:autoload   (gnu packages bootloaders) (grub)
   #:autoload   (gnu packages compression) (gzip)
@@ -50,15 +52,10 @@
             %background-image
             %default-theme
 
-            grub-configuration
-            grub-configuration?
-            grub-configuration-device
-            grub-configuration-grub
+            grub-bootloader
+            grub-efi-bootloader
 
-            menu-entry
-            menu-entry?
-
-            grub-configuration-file))
+            grub-configuration))
 
 ;;; Commentary:
 ;;;
@@ -106,29 +103,6 @@ denoting a file name."
    (color-highlight '((fg . yellow) (bg . black)))
    (color-normal    '((fg . light-gray) (bg . black))))) ;XXX: #x303030
 
-(define-record-type* <grub-configuration>
-  grub-configuration make-grub-configuration
-  grub-configuration?
-  (grub             grub-configuration-grub             ; package
-                    (default (@ (gnu packages bootloaders) grub)))
-  (device           grub-configuration-device)          ; string
-  (menu-entries     grub-configuration-menu-entries     ; list
-                    (default '()))
-  (default-entry    grub-configuration-default-entry    ; integer
-                    (default 0))
-  (timeout          grub-configuration-timeout          ; integer
-                    (default 5))
-  (theme            grub-configuration-theme            ; <grub-theme>
-                    (default %default-theme))
-  (terminal-outputs grub-configuration-terminal-outputs ; list of symbols
-                    (default '(gfxterm)))
-  (terminal-inputs  grub-configuration-terminal-inputs  ; list of symbols
-                    (default '()))
-  (serial-unit      grub-configuration-serial-unit      ; integer | #f
-                    (default #f))
-  (serial-speed     grub-configuration-serial-speed     ; integer | #f
-                    (default #f)))
-
 (define-record-type* <menu-entry>
   menu-entry make-menu-entry
   menu-entry?
@@ -147,6 +121,11 @@ denoting a file name."
 ;;; Background image & themes.
 ;;;
 
+(define (bootloader-theme config)
+  "Return user defined theme in CONFIG if defined or %default-theme
+otherwise."
+  (or (bootloader-configuration-theme config) %default-theme))
+
 (define* (svg->png svg #:key width height)
   "Build a PNG of HEIGHT x WIDTH from SVG."
   (gexp->derivation "grub-image.png"
@@ -171,7 +150,8 @@ WIDTH/HEIGHT, or #f if none was found."
   (let* ((ratio (/ width height))
          (image (find (lambda (image)
                         (= (grub-image-aspect-ratio image) ratio))
-                      (grub-theme-images (grub-configuration-theme config)))))
+                      (grub-theme-images
+                       (bootloader-theme config)))))
     (if image
         (svg->png (grub-image-file image)
                   #:width width #:height height)
@@ -212,14 +192,14 @@ system string---e.g., \"x86_64-linux\"."
         ""))
 
   (define (setup-gfxterm config font-file)
-    (if (memq 'gfxterm (grub-configuration-terminal-outputs config))
-      #~(format #f "if loadfont ~a; then
+    (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
+        #~(format #f "if loadfont ~a; then
   setup_gfxterm
 fi~%" #$font-file)
-      ""))
+        ""))
 
   (define (theme-colors type)
-    (let* ((theme  (grub-configuration-theme config))
+    (let* ((theme  (bootloader-theme config))
            (colors (type theme)))
       (string-append (symbol->string (assoc-ref colors 'fg)) "/"
                      (symbol->string (assoc-ref colors 'bg)))))
@@ -266,10 +246,10 @@ fi~%"
 is a string that can be inserted in grub.cfg."
   (let* ((symbols->string (lambda (list)
                            (string-join (map symbol->string list) " ")))
-         (outputs (grub-configuration-terminal-outputs config))
-         (inputs (grub-configuration-terminal-inputs config))
-         (unit (grub-configuration-serial-unit config))
-         (speed (grub-configuration-serial-speed config))
+         (outputs (bootloader-configuration-terminal-outputs config))
+         (inputs (bootloader-configuration-terminal-inputs config))
+         (unit (bootloader-configuration-serial-unit config))
+         (speed (bootloader-configuration-serial-speed config))
 
          ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
          ;; as documented in GRUB manual section "Simple Configuration
@@ -347,12 +327,13 @@ code."
                                   (system (%current-system))
                                   (old-entries '()))
   "Return the GRUB configuration file corresponding to CONFIG, a
-<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."
+<bootloader-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 (map boot-parameters->menu-entry entries)
-            (grub-configuration-menu-entries config)))
+    (map boot-parameters->menu-entry
+         (append entries
+                 (bootloader-configuration-menu-entries config))))
 
   (define entry->gexp
     (match-lambda
@@ -391,8 +372,8 @@ corresponding to old generations of the system."
             (format port "
 set default=~a
 set timeout=~a~%"
-                    #$(grub-configuration-default-entry config)
-                    #$(grub-configuration-timeout config))
+                    #$(bootloader-configuration-default-entry config)
+                    #$(bootloader-configuration-timeout config))
             #$@(map entry->gexp all-entries)
 
             #$@(if (pair? old-entries)
@@ -404,4 +385,64 @@ submenu \"GNU system, old configurations...\" {~%")
 
     (gexp->derivation "grub.cfg" builder)))
 
+
+
+;;;
+;;; Install procedures.
+;;;
+
+(define install-grub
+  #~(lambda (bootloader device mount-point)
+      ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT.
+      (let ((grub (string-append bootloader "/sbin/grub-install"))
+            (install-dir (string-append mount-point "/boot")))
+        ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
+        ;; root partition.
+        (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
+        (unless (zero? (system* grub "--no-floppy"
+                                "--boot-directory" install-dir
+                                device))
+          (error "failed to install GRUB")))))
+
+
+
+;;;
+;;; Bootloader definitions.
+;;;
+
+(define grub-bootloader
+  (bootloader
+   (name 'grub)
+   (package grub)
+   (installer install-grub)
+   (configuration-file "/boot/grub/grub.cfg")
+   (configuration-file-generator grub-configuration-file)))
+
+(define* grub-efi-bootloader
+  (bootloader
+   (inherit grub-bootloader)
+   (name 'grub-efi)
+   (package grub-efi)))
+
+
+;;;
+;;; Compatibility macros.
+;;;
+
+(define-syntax grub-configuration
+  (syntax-rules (grub)
+                ((_ (grub package) fields ...)
+                 (if (eq? package grub)
+                     (bootloader-configuration
+                      (bootloader grub-bootloader)
+                      fields ...)
+                   (bootloader-configuration
+                    (bootloader grub-efi-bootloader)
+                    fields ...)))
+                ((_ fields ...)
+                 (bootloader-configuration
+                  (bootloader grub-bootloader)
+                  fields ...))))
+
 ;;; grub.scm ends here
diff --git a/gnu/local.mk b/gnu/local.mk
index c560c71725..d0c5b9daf8 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -36,6 +36,9 @@
 GNU_SYSTEM_MODULES =				\
   gnu.scm					\
   %D%/artwork.scm				\
+  %D%/bootloader.scm				\
+  %D%/bootloader/grub.scm                       \
+  %D%/bootloader/extlinux.scm                   \
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
   %D%/packages/abiword.scm			\
@@ -443,7 +446,6 @@ GNU_SYSTEM_MODULES =				\
 						\
   %D%/system.scm				\
   %D%/system/file-systems.scm			\
-  %D%/system/grub.scm				\
   %D%/system/install.scm			\
   %D%/system/linux-container.scm		\
   %D%/system/linux-initrd.scm			\
diff --git a/gnu/system.scm b/gnu/system.scm
index f9a0da9a75..a705bf6900 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -48,6 +48,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
+  #:use-module (gnu bootloader)
   #:use-module (gnu system shadow)
   #:use-module (gnu system nss)
   #:use-module (gnu system locale)
@@ -139,7 +140,7 @@ 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>
 
   (initrd operating-system-initrd                 ; (list fs) -> M derivation
           (default base-initrd))
@@ -847,12 +848,11 @@ populate the \"old entries\" menu."
        (root-device -> (if (eq? 'uuid (file-system-title root-fs))
                            (uuid->string (file-system-device root-fs))
                            (file-system-device root-fs)))
-       (entry (operating-system-boot-parameters os system root-device)))
-    ((module-ref (resolve-interface '(gnu system grub))
-                 'grub-configuration-file)
-     (operating-system-bootloader os)
-     (list entry)
-     #:old-entries old-entries)))
+       (entry (operating-system-boot-parameters os system root-device))
+       (bootloader-conf -> (operating-system-bootloader os)))
+    ((bootloader-configuration-file-generator
+      (bootloader-configuration-bootloader bootloader-conf))
+     bootloader-conf (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/vm.scm b/gnu/system/vm.scm
index 2c8b954c80..080014cde4 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -49,7 +49,7 @@
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module (gnu system linux-initrd)
-  #:use-module (gnu system grub)
+  #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 810711ab91..2886a982f4 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,8 +21,8 @@
   #:use-module (guix gexp)
   #:use-module (guix utils)
   #:use-module (guix records)
+  #:use-module (gnu bootloader grub)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system shadow)
   #:use-module (gnu services)
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 1f28f5a5b8..9e1ac1d55a 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,8 +20,8 @@
 
 (define-module (gnu tests nfs)
   #:use-module (gnu tests)
+  #:use-module (gnu bootloader grub)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)