diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/system.scm | 59 | ||||
| -rw-r--r-- | gnu/system/grub.scm | 85 |
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) |