~ruther/guix-local

0f65f54ebd76324653fd5506a7dab42ee44d9255 — Carlos Sánchez de La Lama 9 years ago d7b342d
system: grub.cfg uses correct file names when store is not in root partition.

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>
3 files changed, 30 insertions(+), 12 deletions(-)

M gnu/system.scm
M gnu/system/grub.scm
M guix/scripts/system.scm
M gnu/system.scm => gnu/system.scm +2 -1
@@ 727,6 727,7 @@ listed in OS.  The C library expects to find it under
       (store-fs -> (operating-system-store-file-system os))
       (label ->    (kernel->grub-label (operating-system-kernel os)))
       (kernel ->   (operating-system-kernel-file os))
       (initrd      (operating-system-initrd-file os))
       (root-device -> (if (eq? 'uuid (file-system-title root-fs))
                           (uuid->string (file-system-device root-fs))
                           (file-system-device root-fs)))


@@ 739,7 740,7 @@ listed in OS.  The C library expects to find it under
                                   #~(string-append "--load=" #$system
                                                    "/boot")
                                   (operating-system-kernel-arguments os)))
                           (initrd (file-append system "/initrd"))))))
                           (initrd initrd)))))
    (grub-configuration-file (operating-system-bootloader os)
                             store-fs entries
                             #:old-entries old-entries)))

M gnu/system/grub.scm => gnu/system/grub.scm +23 -7
@@ 62,6 62,17 @@
;;;
;;; 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>
  grub-image make-grub-image
  grub-image?


@@ 183,7 194,8 @@ the store is.  SYSTEM must be the target system string---e.g.,
                     (symbol->string (assoc-ref colors 'bg)))))

  (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)))
    (return (and image


@@ 209,7 221,7 @@ fi~%"
                           #$(grub-root-search root-fs font-file)
                           #$font-file

                           #$image
                           #$(strip-mount-point root-fs image)
                           #$(theme-colors grub-theme-color-normal)
                           #$(theme-colors grub-theme-color-highlight))))))



@@ 249,15 261,19 @@ corresponding to old generations of the system."
  (define entry->gexp
    (match-lambda
     (($ <menu-entry> label linux arguments initrd)
      #~(format port "menuentry ~s {
      ;; 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 {
  ~a
  linux ~a ~a
  initrd ~a
}~%"
                #$label
                #$(grub-root-search store-fs linux)
                #$linux (string-join (list #$@arguments))
                #$initrd))))
                  #$label
                  #$(grub-root-search store-fs linux)
                  #$linux (string-join (list #$@arguments))
                  #$initrd)))))

  (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
    (define builder

M guix/scripts/system.scm => guix/scripts/system.scm +5 -4
@@ 383,7 383,8 @@ it atomically, and then run OS's activation script."
                                  (uuid->string root)
                                  root))
            (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
        (label (string-append label " (#"
                              (number->string number) ", "


@@ 391,10 392,10 @@ it atomically, and then run OS's activation script."
        (linux kernel)
        (linux-arguments
         (cons* (string-append "--root=" root-device)
                #~(string-append "--system=" #$system)
                #~(string-append "--load=" #$system "/boot")
                (string-append "--system=" system)
                (string-append "--load=" system "/boot")
                kernel-arguments))
        (initrd #~(string-append #$system "/initrd"))))))
        (initrd initrd)))))

  (let* ((numbers (generation-numbers profile))
         (systems (map (cut generation-file-name profile <>)