[PATCH] system: grub: Add 'libreboot?' install flag.

[Jookia]

Libreboot doesn't read GRUB from the disk, it chainloads configuration files. As
such, grub-install is known to fail and require fragile workarounds. To solve
this issue, there's now a 'libreboot?' boolean flag that will instead use
'/boot/grub/libreboot_grub.cfg' for the GRUB menu and not run 'grub-install'.

* gnu/system/grub.scm (<grub-configuration>): Add and export 'libreboot?' flag.
* doc/guix.texi (GRUB Configuration): Explain the 'libreboot?' flag.
* guix/scripts/system.scm: Read and use 'libreboot?' flag when installing GRUB.
  (process-action): Read GRUB's 'libreboot?' flag and pass it to perform-action.
  (perform-action): Pass the 'libreboot?' flag to 'install-grub*' and 'install'.
  (install): Pass the 'libreboot?' flag to install-grub*.
  (install-grub*): Pass the 'libreboot?' flag to install-grub.
* gnu/build/install.scm (install-grub): Read 'libreboot?' flag and based on this
  decide where to put the grub.cfg file and whether to run grub-install.
---
 doc/guix.texi           |  6 ++++++
 gnu/build/install.scm   | 21 +++++++++++++--------
 gnu/system/grub.scm     |  4 ++++
 guix/scripts/system.scm | 23 ++++++++++++++---------
 4 files changed, 37 insertions(+), 17 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 11664f4..704809f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -17,6 +17,7 @@ Copyright @copyright{} 2015 Mathieu address@hidden
 Copyright @copyright{} 2014 Pierre-Antoine address@hidden
 Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/address@hidden
 Copyright @copyright{} 2015, 2016 Leo Famulari
+Copyright @copyright{} 2016 Jookia
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -9132,6 +9133,11 @@ understood by the @command{grub-install} command, such as
 @code{/dev/sda} or @code{(hd0)} (@pxref{Invoking grub-install,,, grub,
 GNU GRUB Manual}).
 
address@hidden @code{libreboot?} (default: @code{#f})
+Setting this boolean to true will tweak GRUB for systems running Libreboot with
+the GRUB payload.  Instead of installing GRUB to disk, a configuration will be
+put in @code{/boot/grub/libreboot_grub.cfg} for Libreboot to load.
+
 @item @code{menu-entries} (default: @code{()})
 A possibly empty list of @code{menu-entry} objects (see below), denoting
 entries to appear in the GRUB boot menu, in addition to the current
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 9785b6d..471ff58 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,15 +37,17 @@
 ;;;
 ;;; Code:
 
-(define* (install-grub grub.cfg device mount-point)
+(define* (install-grub grub.cfg device mount-point libreboot?)
   "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
 MOUNT-POINT.
 
 Note that the caller must make sure that GRUB.CFG is registered as a GC root
 so that the fonts, background images, etc. referred to by GRUB.CFG are not
 GC'd."
-  (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
-         (pivot  (string-append target ".new")))
+  (let* ((base (string-append mount-point "/boot/grub/"))
+         (target (string-append base "grub.cfg"))
+         (pivot  (string-append target ".new"))
+         (librebooter (string-append base "libreboot_grub.cfg")))
     (mkdir-p (dirname target))
 
     ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
@@ -52,11 +55,13 @@ GC'd."
     (copy-file grub.cfg pivot)
     (rename-file pivot target)
 
-    (unless (zero? (system* "grub-install" "--no-floppy"
-                            "--boot-directory"
-                            (string-append mount-point "/boot")
-                            device))
-      (error "failed to install GRUB"))))
+    (if libreboot?
+      (rename-file target librebooter)
+      (unless (zero? (system* "grub-install" "--no-floppy"
+                              "--boot-directory"
+                              (string-append mount-point "/boot")
+                              device))
+        (error "failed to install GRUB")))))
 
 (define (evaluate-populate-directive directive target)
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..d5a2df0 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +51,7 @@
             grub-configuration
             grub-configuration?
             grub-configuration-device
+            grub-configuration-libreboot
 
             menu-entry
             menu-entry?
@@ -98,6 +100,8 @@
   (grub            grub-configuration-grub           ; package
                    (default (@ (gnu packages grub) grub)))
   (device          grub-configuration-device)        ; string
+  (libreboot?      grub-configuration-libreboot      ; bool
+                   (default #f))
   (menu-entries    grub-configuration-menu-entries   ; list
                    (default '()))
   (default-entry   grub-configuration-default-entry  ; integer
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e31eec6..d0e7e77 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -122,7 +123,7 @@ TARGET, and register them."
               (map (cut copy-item <> target #:log-port log-port)
                    to-copy))))
 
-(define (install-grub* grub.cfg device target)
+(define (install-grub* grub.cfg device target libreboot?)
   "This is a variant of 'install-grub' with error handling, lifted in
 %STORE-MONAD"
   (let* ((gc-root      (string-append %gc-roots-directory "/grub.cfg"))
@@ -135,7 +136,7 @@ TARGET, and register them."
       ;; 'install-grub' completes (being a bit paranoid.)
       (make-symlink temp-gc-root grub.cfg)
 
-      (munless (false-if-exception (install-grub grub.cfg device target))
+      (munless (false-if-exception (install-grub grub.cfg device target 
libreboot?))
         (delete-file temp-gc-root)
         (leave (_ "failed to install GRUB on device '~a'~%") device))
 
@@ -145,7 +146,7 @@ TARGET, and register them."
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
-                  grub? grub.cfg device)
+                  grub? grub.cfg device libreboot?)
   "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
 'guix-register' expects.
@@ -188,7 +189,7 @@ the ownership of '~a' may be incorrect!~%")
       (populate os-dir target)
 
       (mwhen grub?
-        (install-grub* grub.cfg device target)))))
+        (install-grub* grub.cfg device target libreboot?)))))
 
 
 ;;;
@@ -391,7 +392,7 @@ PATTERN, a string.  When PATTERN is #f, display all the 
system generations."
 
 (define* (perform-action action os
                          #:key grub? dry-run? derivations-only?
-                         use-substitutes? device target
+                         use-substitutes? device libreboot? target
                          image-size full-boot?
                          (mappings '()))
   "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
@@ -451,7 +452,7 @@ building anything."
                (switch-to-system os)
                (mwhen grub?
                  (install-grub* (derivation->output-path grub.cfg)
-                                device "/"))))
+                                device "/" libreboot?))))
             ((init)
              (newline)
              (format #t (_ "initializing operating system under '~a'...~%")
@@ -459,7 +460,8 @@ building anything."
              (install sys (canonicalize-path target)
                       #:grub? grub?
                       #:grub.cfg (derivation->output-path grub.cfg)
-                      #:device device))
+                      #:device device
+                      #:libreboot? libreboot?))
             (else
              ;; All we had to do was to build SYS.
              (return (derivation->output-path sys))))))))
@@ -626,7 +628,9 @@ resulting from command-line parsing."
                      (_ #f)))
          (device   (and grub?
                         (grub-configuration-device
-                         (operating-system-bootloader os)))))
+                         (operating-system-bootloader os))))
+         (libreboot? (grub-configuration-libreboot
+                      (operating-system-bootloader os))))
 
     (with-store store
       (set-build-options-from-command-line store opts)
@@ -653,7 +657,8 @@ resulting from command-line parsing."
                                                       (_ #f))
                                                     opts)
                              #:grub? grub?
-                             #:target target #:device device))))
+                             #:target target #:device device
+                             #:libreboot? libreboot?))))
         #:system system))))
 
 (define (process-command command args opts)
-- 
2.7.0