mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
system: grub: Search root device by label or UUID if possible.
Fixes <http://bugs.gnu.org/22281>. Reported by Christopher Allan Webber <cwebber@dustycloud.org>. * gnu/system/grub.scm (eye-candy): Add 'root-fs' parameter. Replace 'search --file' command in the output with whatever 'grub-root-search' returns. (grub-root-search): New procedure. (grub-configuration-file): Add 'store-fs' parameter. Use 'grub-root-search' instead of hard-coded 'search --file' commands. * gnu/system.scm (store-file-system, operating-system-store-file-system): New procedures. (operating-system-grub.cfg): Use it, and adjust call to 'grub-configuration-file'. * tests/system.scm: New file. * Makefile.am (SCM_TESTS): Add it.
This commit is contained in:
parent
3738d8700f
commit
6b779207ee
4 changed files with 143 additions and 15 deletions
|
@ -240,6 +240,7 @@ SCM_TESTS = \
|
|||
tests/challenge.scm \
|
||||
tests/cve.scm \
|
||||
tests/file-systems.scm \
|
||||
tests/system.scm \
|
||||
tests/services.scm \
|
||||
tests/containers.scm \
|
||||
tests/import-utils.scm
|
||||
|
|
|
@ -79,6 +79,7 @@ (define-module (gnu system)
|
|||
operating-system-locale-libcs
|
||||
operating-system-mapped-devices
|
||||
operating-system-file-systems
|
||||
operating-system-store-file-system
|
||||
operating-system-activation-script
|
||||
|
||||
operating-system-derivation
|
||||
|
@ -678,12 +679,34 @@ (define (kernel->grub-label kernel)
|
|||
(package-version kernel)
|
||||
" (alpha)"))
|
||||
|
||||
(define (store-file-system file-systems)
|
||||
"Return the file system object among FILE-SYSTEMS that contains the store."
|
||||
(match (filter (lambda (fs)
|
||||
(and (file-system-mount? fs)
|
||||
(not (memq 'bind-mount (file-system-flags fs)))
|
||||
(string-prefix? (file-system-mount-point fs)
|
||||
(%store-prefix))))
|
||||
file-systems)
|
||||
((and candidates (head . tail))
|
||||
(reduce (lambda (fs1 fs2)
|
||||
(if (> (string-length (file-system-mount-point fs1))
|
||||
(string-length (file-system-mount-point fs2)))
|
||||
fs1
|
||||
fs2))
|
||||
head
|
||||
candidates))))
|
||||
|
||||
(define (operating-system-store-file-system os)
|
||||
"Return the file system that contains the store of OS."
|
||||
(store-file-system (operating-system-file-systems os)))
|
||||
|
||||
(define* (operating-system-grub.cfg os #:optional (old-entries '()))
|
||||
"Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the
|
||||
\"old entries\" menu."
|
||||
(mlet* %store-monad
|
||||
((system (operating-system-derivation os))
|
||||
(root-fs -> (operating-system-root-file-system os))
|
||||
(store-fs -> (operating-system-store-file-system os))
|
||||
(kernel -> (operating-system-kernel os))
|
||||
(root-device -> (if (eq? 'uuid (file-system-title root-fs))
|
||||
(uuid->string (file-system-device root-fs))
|
||||
|
@ -698,7 +721,8 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '()))
|
|||
"/boot")
|
||||
(operating-system-kernel-arguments os)))
|
||||
(initrd #~(string-append #$system "/initrd"))))))
|
||||
(grub-configuration-file (operating-system-bootloader os) entries
|
||||
(grub-configuration-file (operating-system-bootloader os)
|
||||
store-fs entries
|
||||
#:old-entries old-entries)))
|
||||
|
||||
(define (operating-system-parameters-file os)
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -25,6 +25,7 @@ (define-module (gnu system grub)
|
|||
#:use-module (guix gexp)
|
||||
#:use-module (guix download)
|
||||
#:use-module (gnu artwork)
|
||||
#:use-module (gnu system file-systems)
|
||||
#:autoload (gnu packages grub) (grub)
|
||||
#:autoload (gnu packages inkscape) (inkscape)
|
||||
#:autoload (gnu packages imagemagick) (imagemagick)
|
||||
|
@ -153,10 +154,12 @@ (define* (grub-background-image config #:key (width 1024) (height 768))
|
|||
(with-monad %store-monad
|
||||
(return #f)))))
|
||||
|
||||
(define (eye-candy config system port)
|
||||
(define (eye-candy config root-fs 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."
|
||||
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\"."
|
||||
(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
|
||||
|
@ -179,15 +182,18 @@ (define (theme-colors type)
|
|||
(string-append (symbol->string (assoc-ref colors 'fg)) "/"
|
||||
(symbol->string (assoc-ref colors 'bg)))))
|
||||
|
||||
(define font-file
|
||||
#~(string-append #$grub "/share/grub/unicode.pf2"))
|
||||
|
||||
(mlet* %store-monad ((image (grub-background-image config)))
|
||||
(return (and image
|
||||
#~(format #$port "
|
||||
function setup_gfxterm {~a}
|
||||
|
||||
# Set 'root' to the partition that contains /gnu/store.
|
||||
search --file --set ~a/share/grub/unicode.pf2
|
||||
~a
|
||||
|
||||
if loadfont ~a/share/grub/unicode.pf2; then
|
||||
if loadfont ~a; then
|
||||
setup_gfxterm
|
||||
fi
|
||||
|
||||
|
@ -200,7 +206,9 @@ (define (theme-colors type)
|
|||
set menu_color_highlight=white/blue
|
||||
fi~%"
|
||||
#$setup-gfxterm-body
|
||||
#$grub #$grub
|
||||
#$(grub-root-search root-fs font-file)
|
||||
#$font-file
|
||||
|
||||
#$image
|
||||
#$(theme-colors grub-theme-color-normal)
|
||||
#$(theme-colors grub-theme-color-highlight))))))
|
||||
|
@ -210,13 +218,31 @@ (define (theme-colors type)
|
|||
;;; Configuration file.
|
||||
;;;
|
||||
|
||||
(define* (grub-configuration-file config entries
|
||||
(define (grub-root-search root-fs file)
|
||||
"Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
|
||||
a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
|
||||
code."
|
||||
(case (file-system-title root-fs)
|
||||
;; Preferably refer to ROOT-FS by its UUID or label. This is more
|
||||
;; efficient and less ambiguous, see <>.
|
||||
((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.
|
||||
#~(format #f "search --file --set ~a" #$file))))
|
||||
|
||||
(define* (grub-configuration-file config store-fs entries
|
||||
#:key
|
||||
(system (%current-system))
|
||||
(old-entries '()))
|
||||
"Return the GRUB configuration file corresponding to CONFIG, a
|
||||
<grub-configuration> object. OLD-ENTRIES is taken to be a list of menu
|
||||
entries corresponding to old generations of the system."
|
||||
<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."
|
||||
(define linux-image-name
|
||||
(if (string-prefix? "mips" system)
|
||||
"vmlinuz"
|
||||
|
@ -229,18 +255,18 @@ (define entry->gexp
|
|||
(match-lambda
|
||||
(($ <menu-entry> label linux arguments initrd)
|
||||
#~(format port "menuentry ~s {
|
||||
# Set 'root' to the partition that contains the kernel.
|
||||
search --file --set ~a/~a~%
|
||||
|
||||
~a
|
||||
linux ~a/~a ~a
|
||||
initrd ~a
|
||||
}~%"
|
||||
#$label
|
||||
#$linux #$linux-image-name
|
||||
#$(grub-root-search store-fs
|
||||
#~(string-append #$linux "/"
|
||||
#$linux-image-name))
|
||||
#$linux #$linux-image-name (string-join (list #$@arguments))
|
||||
#$initrd))))
|
||||
|
||||
(mlet %store-monad ((sugar (eye-candy config system #~port)))
|
||||
(mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
|
||||
(define builder
|
||||
#~(call-with-output-file #$output
|
||||
(lambda (port)
|
||||
|
|
77
tests/system.scm
Normal file
77
tests/system.scm
Normal file
|
@ -0,0 +1,77 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; 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 (test-system)
|
||||
#:use-module (gnu)
|
||||
#:use-module (guix store)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-64))
|
||||
|
||||
;; Test the (gnu system) module.
|
||||
|
||||
(define %root-fs
|
||||
(file-system
|
||||
(device "my-root")
|
||||
(title 'label)
|
||||
(mount-point "/")
|
||||
(type "ext4")))
|
||||
|
||||
(define %os
|
||||
(operating-system
|
||||
(host-name "komputilo")
|
||||
(timezone "Europe/Berlin")
|
||||
(locale "en_US.utf8")
|
||||
(bootloader (grub-configuration (device "/dev/sdX")))
|
||||
(file-systems (cons %root-fs %base-file-systems))
|
||||
|
||||
(users %base-user-accounts)))
|
||||
|
||||
(test-begin "system")
|
||||
|
||||
(test-assert "operating-system-store-file-system"
|
||||
;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
|
||||
;; shouldn't be a problem.
|
||||
(eq? %root-fs
|
||||
(operating-system-store-file-system %os)))
|
||||
|
||||
(test-assert "operating-system-store-file-system, prefix"
|
||||
(let* ((gnu (file-system
|
||||
(device "foobar")
|
||||
(mount-point (dirname (%store-prefix)))
|
||||
(type "ext5")))
|
||||
(os (operating-system
|
||||
(inherit %os)
|
||||
(file-systems (cons* gnu %root-fs
|
||||
%base-file-systems)))))
|
||||
(eq? gnu (operating-system-store-file-system os))))
|
||||
|
||||
(test-assert "operating-system-store-file-system, store"
|
||||
(let* ((gnu (file-system
|
||||
(device "foobar")
|
||||
(mount-point (%store-prefix))
|
||||
(type "ext5")))
|
||||
(os (operating-system
|
||||
(inherit %os)
|
||||
(file-systems (cons* gnu %root-fs
|
||||
%base-file-systems)))))
|
||||
(eq? gnu (operating-system-store-file-system os))))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|
Loading…
Reference in a new issue