From d5b429abda948c21a61032a1da9d472410edaa90 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 18 May 2014 21:58:01 +0200
Subject: [PATCH] system: Add 'grub-configuration' record.

* gnu/system/grub.scm (<grub-configuration>): New record type.
  (grub-configuration-file): Add 'config' parameter; remove
  #:default-entry and #:timeout.  Honor CONFIG.
* gnu/system.scm (<operating-system>): Remove 'bootloader-entries'
  field; remove default value for 'bootloader' field.
  (operating-system-grub.cfg): Pass the 'bootloader' field to
  'grub-configuration-file'.
* build-aux/hydra/demo-os.scm (bootloader): New field.
---
 build-aux/hydra/demo-os.scm |  3 +++
 gnu/system.scm              | 11 +++++------
 gnu/system/grub.scm         | 39 ++++++++++++++++++++++++++++---------
 3 files changed, 38 insertions(+), 15 deletions(-)

diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm
index 32c6fa3abf..fe9c77242e 100644
--- a/build-aux/hydra/demo-os.scm
+++ b/build-aux/hydra/demo-os.scm
@@ -33,6 +33,7 @@
              (gnu packages tor)
              (gnu packages package-management)
 
+             (gnu system grub)                    ; 'grub-configuration'
              (gnu system shadow)                  ; 'user-account'
              (gnu system linux)                   ; 'base-pam-services'
              (gnu services base)
@@ -43,6 +44,8 @@
  (host-name "gnu")
  (timezone "Europe/Paris")
  (locale "en_US.UTF-8")
+ (bootloader (grub-configuration
+              (device "/dev/sda")))
  (file-systems
   ;; We provide a dummy file system for /, but that's OK because the VM build
   ;; code will automatically declare the / file system for us.
diff --git a/gnu/system.scm b/gnu/system.scm
index ec3e2fcd6c..dd44878462 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -39,10 +39,11 @@ (define-module (gnu system)
   #:use-module (srfi srfi-26)
   #:export (operating-system
             operating-system?
+
+            operating-system-bootloader
             operating-system-services
             operating-system-user-services
             operating-system-packages
-            operating-system-bootloader-entries
             operating-system-host-name
             operating-system-kernel
             operating-system-initrd
@@ -83,10 +84,8 @@ (define-record-type* <operating-system> operating-system
   operating-system?
   (kernel operating-system-kernel                 ; package
           (default linux-libre))
-  (bootloader operating-system-bootloader         ; package
-              (default grub))
-  (bootloader-entries operating-system-bootloader-entries ; list
-                      (default '()))
+  (bootloader operating-system-bootloader)        ; <grub-configuration>
+
   (initrd operating-system-initrd                 ; (list fs) -> M derivation
           (default qemu-initrd))
 
@@ -504,7 +503,7 @@ (define (operating-system-grub.cfg os)
                                   #~(string-append "--load=" #$system
                                                    "/boot")))
                            (initrd #~(string-append #$system "/initrd"))))))
-    (grub-configuration-file entries)))
+    (grub-configuration-file (operating-system-bootloader os) entries)))
 
 (define (operating-system-derivation os)
   "Return a derivation that builds OS."
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 1893672a2a..e789e4c591 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -25,8 +25,13 @@ (define-module (gnu system grub)
   #:use-module (guix gexp)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (menu-entry
+  #:export (grub-configuration
+            grub-configuration?
+            grub-configuration-device
+
+            menu-entry
             menu-entry?
+
             grub-configuration-file))
 
 ;;; Commentary:
@@ -35,6 +40,19 @@ (define-module (gnu system grub)
 ;;;
 ;;; Code:
 
+(define-record-type* <grub-configuration>
+  grub-configuration make-grub-configuration
+  grub-configuration?
+  (grub            grub-configuration-grub           ; package
+                   (default (@ (gnu packages grub) grub)))
+  (device          grub-configuration-device)        ; string
+  (menu-entries    grub-configuration-menu-entries   ; list
+                   (default '()))
+  (default-entry   grub-configuration-default-entry  ; integer
+                   (default 1))
+  (timeout         grub-configuration-timeout        ; integer
+                   (default 5)))
+
 (define-record-type* <menu-entry>
   menu-entry make-menu-entry
   menu-entry?
@@ -44,11 +62,13 @@ (define-record-type* <menu-entry>
                    (default '()))          ; list of string-valued gexps
   (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp
 
-(define* (grub-configuration-file entries
-                                  #:key (default-entry 1) (timeout 5)
-                                  (system (%current-system)))
-  "Return the GRUB configuration file for ENTRIES, a list of
-<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
+(define* (grub-configuration-file config entries
+                                  #:key (system (%current-system)))
+  "Return the GRUB configuration file corresponding to CONFIG, a
+<grub-configuration> object."
+  (define all-entries
+    (append entries (grub-configuration-menu-entries config)))
+
   (define entry->gexp
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
@@ -67,12 +87,13 @@ (define builder
 set default=~a
 set timeout=~a
 search.file ~a/bzImage~%"
-                  #$default-entry #$timeout
+                  #$(grub-configuration-default-entry config)
+                  #$(grub-configuration-timeout config)
                   #$(any (match-lambda
                           (($ <menu-entry> _ linux)
                            linux))
-                         entries))
-          #$@(map entry->gexp entries))))
+                         all-entries))
+          #$@(map entry->gexp all-entries))))
 
   (gexp->derivation "grub.cfg" builder))