ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

system: grub.cfg uses correct file names when store is not in root partition.

Browse source 
Fixes <http://bugs.gnu.org/24346>.
Reported by csanchezdll@gmail.com (Carlos Sánchez de La Lama).

* guix/scripts/system.scm (previous-grub-entries): Get the initrd file
name from PARAMS.
* gnu/system.scm (operating-system-grub.cfg): Use
'operating-system-initrd-file' to retrieve the initrd file name.
* gnu/system/grub.scm (strip-mount-point): New procedure.
(grub-configuration-file)[entry->gexp]: Call 'strip-mount-point' for
LINUX and INITRD.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Carlos Sánchez de La Lama 2016-09-14 16:13:24 +02:00 committed by Ludovic Courtès
parent d7b342d815
commit 0f65f54ebd
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 30 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
gnu/system.scm
View file

@ -727,6 +727,7 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '()))
(store-fs -> (operating-system-store-file-system os)) (store-fs -> (operating-system-store-file-system os))
(label -> (kernel->grub-label (operating-system-kernel os))) (label -> (kernel->grub-label (operating-system-kernel os)))
(kernel -> (operating-system-kernel-file os)) (kernel -> (operating-system-kernel-file os))
(initrd (operating-system-initrd-file os))
(root-device -> (if (eq? 'uuid (file-system-title root-fs)) (root-device -> (if (eq? 'uuid (file-system-title root-fs))
(uuid->string (file-system-device root-fs)) (uuid->string (file-system-device root-fs))
(file-system-device root-fs))) (file-system-device root-fs)))
@ -739,7 +740,7 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '()))
#~(string-append "--load=" #$system #~(string-append "--load=" #$system
"/boot") "/boot")
(operating-system-kernel-arguments os))) (operating-system-kernel-arguments os)))
(initrd (file-append system "/initrd")))))) (initrd initrd)))))
(grub-configuration-file (operating-system-bootloader os) (grub-configuration-file (operating-system-bootloader os)
store-fs entries store-fs entries
#:old-entries old-entries))) #:old-entries old-entries)))

22
gnu/system/grub.scm
View file

@ -62,6 +62,17 @@ (define-module (gnu system grub)
;;; ;;;
;;; Code: ;;; 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-record-type* <grub-image> (define-record-type* <grub-image>
grub-image make-grub-image grub-image make-grub-image
grub-image? grub-image?
@ -183,7 +194,8 @@ (define (theme-colors type)
(symbol->string (assoc-ref colors 'bg))))) (symbol->string (assoc-ref colors 'bg)))))
(define font-file (define font-file
#~(string-append #$grub "/share/grub/unicode.pf2")) (strip-mount-point root-fs
(file-append grub "/share/grub/unicode.pf2")))
(mlet* %store-monad ((image (grub-background-image config))) (mlet* %store-monad ((image (grub-background-image config)))
(return (and image (return (and image
@ -209,7 +221,7 @@ (define font-file
#$(grub-root-search root-fs font-file) #$(grub-root-search root-fs font-file)
#$font-file #$font-file
#$image #$(strip-mount-point root-fs image)
#$(theme-colors grub-theme-color-normal) #$(theme-colors grub-theme-color-normal)
#$(theme-colors grub-theme-color-highlight)))))) #$(theme-colors grub-theme-color-highlight))))))
@ -249,6 +261,10 @@ (define all-entries
(define entry->gexp (define entry->gexp
(match-lambda (match-lambda
(($ <menu-entry> label linux arguments initrd) (($ <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)))
#~(format port "menuentry ~s { #~(format port "menuentry ~s {
~a ~a
linux ~a ~a linux ~a ~a
@ -257,7 +273,7 @@ (define entry->gexp
#$label #$label
#$(grub-root-search store-fs linux) #$(grub-root-search store-fs linux)
#$linux (string-join (list #$@arguments)) #$linux (string-join (list #$@arguments))
#$initrd)))) #$initrd)))))
(mlet %store-monad ((sugar (eye-candy config store-fs system #~port))) (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
(define builder (define builder

9
guix/scripts/system.scm
View file

@ -383,7 +383,8 @@ (define (system->grub-entry system number time)
(uuid->string root) (uuid->string root)
root)) root))
(kernel (boot-parameters-kernel params)) (kernel (boot-parameters-kernel params))
(kernel-arguments (boot-parameters-kernel-arguments params))) (kernel-arguments (boot-parameters-kernel-arguments params))
(initrd (boot-parameters-initrd params)))
(menu-entry (menu-entry
(label (string-append label " (#" (label (string-append label " (#"
(number->string number) ", " (number->string number) ", "
@ -391,10 +392,10 @@ (define (system->grub-entry system number time)
(linux kernel) (linux kernel)
(linux-arguments (linux-arguments
(cons* (string-append "--root=" root-device) (cons* (string-append "--root=" root-device)
#~(string-append "--system=" #$system) (string-append "--system=" system)
#~(string-append "--load=" #$system "/boot") (string-append "--load=" system "/boot")
kernel-arguments)) kernel-arguments))
(initrd #~(string-append #$system "/initrd")))))) (initrd initrd)))))
(let* ((numbers (generation-numbers profile)) (let* ((numbers (generation-numbers profile))
(systems (map (cut generation-file-name profile <>) (systems (map (cut generation-file-name profile <>)