summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/system.scm59
-rw-r--r--gnu/system/grub.scm85
2 files changed, 98 insertions, 46 deletions
diff --git a/gnu/system.scm b/gnu/system.scm
index 38ae8f1771..259875d761 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -99,6 +100,8 @@
boot-parameters?
boot-parameters-label
boot-parameters-root-device
+ boot-parameters-store-device
+ boot-parameters-store-mount-point
boot-parameters-kernel
boot-parameters-kernel-arguments
boot-parameters-initrd
@@ -733,6 +736,12 @@ listed in OS. The C library expects to find it under
(file-system-device root-fs)))
(entries -> (list (menu-entry
(label label)
+
+ ;; The device where the kernel and initrd live.
+ (device (file-system-device store-fs))
+ (device-mount-point
+ (file-system-mount-point store-fs))
+
(linux kernel)
(linux-arguments
(cons* (string-append "--root=" root-device)
@@ -741,8 +750,7 @@ listed in OS. The C library expects to find it under
"/boot")
(operating-system-kernel-arguments os)))
(initrd initrd)))))
- (grub-configuration-file (operating-system-bootloader os)
- store-fs entries
+ (grub-configuration-file (operating-system-bootloader os) entries
#:old-entries old-entries)))
(define (operating-system-parameters-file os)
@@ -750,16 +758,24 @@ listed in OS. The C library expects to find it under
this file is the reconstruction of GRUB menu entries for old configurations."
(mlet %store-monad ((initrd (operating-system-initrd-file os))
(root -> (operating-system-root-file-system os))
+ (store -> (operating-system-store-file-system os))
(label -> (kernel->grub-label
(operating-system-kernel os))))
(gexp->file "parameters"
- #~(boot-parameters (version 0)
- (label #$label)
- (root-device #$(file-system-device root))
- (kernel #$(operating-system-kernel-file os))
- (kernel-arguments
- #$(operating-system-kernel-arguments os))
- (initrd #$initrd))
+ #~(boot-parameters
+ (version 0)
+ (label #$label)
+ (root-device #$(file-system-device root))
+ (kernel #$(operating-system-kernel-file os))
+ (kernel-arguments
+ #$(operating-system-kernel-arguments os))
+ (initrd #$initrd)
+ (store
+ (device #$(case (file-system-title store)
+ ((uuid) (file-system-device store))
+ ((label) (file-system-device store))
+ (else #f)))
+ (mount-point #$(file-system-mount-point store))))
#:set-load-path? #f)))
@@ -770,7 +786,16 @@ this file is the reconstruction of GRUB menu entries for old configurations."
(define-record-type* <boot-parameters>
boot-parameters make-boot-parameters boot-parameters?
(label boot-parameters-label)
+ ;; Because we will use the 'store-device' to create the GRUB search command,
+ ;; the 'store-device' has slightly different semantics than 'root-device'.
+ ;; The 'store-device' can be a file system uuid, a file system label, or #f,
+ ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
+ ;; understand that. The 'root-device', on the other hand, corresponds
+ ;; exactly to the device field of the <file-system> object representing the
+ ;; OS's root file system, so it might be a device path like "/dev/sda3".
(root-device boot-parameters-root-device)
+ (store-device boot-parameters-store-device)
+ (store-mount-point boot-parameters-store-mount-point)
(kernel boot-parameters-kernel)
(kernel-arguments boot-parameters-kernel-arguments)
(initrd boot-parameters-initrd))
@@ -804,7 +829,21 @@ this file is the reconstruction of GRUB menu entries for old configurations."
(('initrd ('string-append directory file)) ;the old format
(string-append directory file))
(('initrd (? string? file))
- file)))))
+ file)))
+
+ (store-device
+ (match (assq 'store rest)
+ (('store ('device device) _ ...)
+ device)
+ (_ ;the old format
+ root)))
+
+ (store-mount-point
+ (match (assq 'store rest)
+ (('store ('device _) ('mount-point mount-point) _ ...)
+ mount-point)
+ (_ ;the old format
+ "/")))))
(x ;unsupported format
(warning (_ "unrecognized boot parameters for '~a'~%")
system)
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 249b415ab4..5c9d0f15a1 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 <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,6 +33,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
+ #:use-module (rnrs bytevectors)
#:export (grub-image
grub-image?
grub-image-aspect-ratio
@@ -61,16 +63,15 @@
;;;
;;; Code:
-(define (strip-mount-point fs file)
- "Strip the mount point of FS from FILE, which is a gexp or other lowerable
-object denoting a file name."
- (let ((mount-point (file-system-mount-point fs)))
- (if (string=? mount-point "/")
- file
- #~(let ((file #$file))
- (if (string-prefix? #$mount-point file)
- (substring #$file #$(string-length mount-point))
- file)))))
+(define (strip-mount-point mount-point file)
+ "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
+denoting a file name."
+ (if (string=? mount-point "/")
+ file
+ #~(let ((file #$file))
+ (if (string-prefix? #$mount-point file)
+ (substring #$file #$(string-length mount-point))
+ file))))
(define-record-type* <grub-image>
grub-image make-grub-image
@@ -121,6 +122,10 @@ object denoting a file name."
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
+ (device menu-entry-device ; file system uuid, label, or #f
+ (default #f))
+ (device-mount-point menu-entry-device-mount-point
+ (default "/"))
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '())) ; list of string-valued gexps
@@ -162,12 +167,14 @@ WIDTH/HEIGHT, or #f if none was found."
(with-monad %store-monad
(return #f)))))
-(define (eye-candy config root-fs system port)
+(define* (eye-candy config store-device store-mount-point
+ #:key system port)
"Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
'grub.cfg' part concerned with graphics mode, background images, colors, and
-all that. ROOT-FS is a file-system object denoting the root file system where
-the store is. SYSTEM must be the target system string---e.g.,
-\"x86_64-linux\"."
+all that. STORE-DEVICE designates the device holding the store, and
+STORE-MOUNT-POINT is its mount point; these are used to determine where the
+background image and fonts must be searched for. SYSTEM must be the target
+system string---e.g., \"x86_64-linux\"."
(define setup-gfxterm-body
;; Intel systems need to be switched into graphics mode, whereas most
;; other modern architectures have no other mode and therefore don't need
@@ -191,7 +198,7 @@ the store is. SYSTEM must be the target system string---e.g.,
(symbol->string (assoc-ref colors 'bg)))))
(define font-file
- (strip-mount-point root-fs
+ (strip-mount-point store-mount-point
(file-append grub "/share/grub/unicode.pf2")))
(mlet* %store-monad ((image (grub-background-image config)))
@@ -215,10 +222,10 @@ else
set menu_color_highlight=white/blue
fi~%"
#$setup-gfxterm-body
- #$(grub-root-search root-fs font-file)
+ #$(grub-root-search store-device font-file)
#$font-file
- #$(strip-mount-point root-fs image)
+ #$(strip-mount-point store-mount-point image)
#$(theme-colors grub-theme-color-normal)
#$(theme-colors grub-theme-color-highlight))))))
@@ -227,8 +234,8 @@ fi~%"
;;; Configuration file.
;;;
-(define (grub-root-search root-fs file)
- "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
+(define (grub-root-search device file)
+ "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
code."
;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
@@ -236,20 +243,18 @@ code."
;; custom menu entries. In the latter case, don't emit a 'search' command.
(if (and (string? file) (not (string-prefix? "/" file)))
""
- (case (file-system-title root-fs)
- ;; Preferably refer to ROOT-FS by its UUID or label. This is more
+ (match device
+ ;; Preferably refer to DEVICE by its UUID or label. This is more
;; efficient and less ambiguous, see <>.
- ((uuid)
+ ((? bytevector? uuid)
(format #f "search --fs-uuid --set ~a"
- (uuid->string (file-system-device root-fs))))
- ((label)
- (format #f "search --label --set ~a"
- (file-system-device root-fs)))
- (else
- ;; As a last resort, look for any device containing FILE.
+ (uuid->string device)))
+ ((? string? label)
+ (format #f "search --label --set ~a" label))
+ (#f
#~(format #f "search --file --set ~a" #$file)))))
-(define* (grub-configuration-file config store-fs entries
+(define* (grub-configuration-file config entries
#:key
(system (%current-system))
(old-entries '()))
@@ -262,22 +267,30 @@ corresponding to old generations of the system."
(define entry->gexp
(match-lambda
- (($ <menu-entry> label linux arguments initrd)
- ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is
- ;; not the "/" file system.
- (let ((linux (strip-mount-point store-fs linux))
- (initrd (strip-mount-point store-fs initrd)))
+ (($ <menu-entry> label device device-mount-point
+ linux arguments initrd)
+ ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+ ;; Use the right file names for LINUX and INITRD in case
+ ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+ ;; separate partition.
+ (let ((linux (strip-mount-point device-mount-point linux))
+ (initrd (strip-mount-point device-mount-point initrd)))
#~(format port "menuentry ~s {
~a
linux ~a ~a
initrd ~a
}~%"
#$label
- #$(grub-root-search store-fs linux)
+ #$(grub-root-search device linux)
#$linux (string-join (list #$@arguments))
#$initrd)))))
- (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
+ (mlet %store-monad ((sugar (eye-candy config
+ (menu-entry-device (first entries))
+ (menu-entry-device-mount-point
+ (first entries))
+ #:system system
+ #:port #~port)))
(define builder
#~(call-with-output-file #$output
(lambda (port)