all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: csanchezdll@gmail.com (Carlos Sánchez de La Lama)
To: 24344@debbugs.gnu.org
Subject: bug#24344: [PATCH] Generate grub.cfg with correct paths when store is not in root partition
Date: Tue, 13 Sep 2016 13:23:31 +0200	[thread overview]
Message-ID: <7toa3s11sc.fsf@gmail.com> (raw)
In-Reply-To: <7twpix5ck2.fsf@gmail.com>

Took a while to produce a working patch :S

A little explanation of what it does:

guix/scripts/system.scm: when constructing old entries, we know
"systems" are the system symlinks in /var/guix/profile, and not a store
derivation. No need for gexps then, which is good as resolving the
symlink using "readlink" cannot be done by the builders /var is not in
the chroot).

gnu/system.scm: for the current system, initrd is inside the system
derivattion in the store. Resolve the symlink at build time.

gnu/system/grub.scm: strip the mount point on the paths GRUB will use,
so GRUB modules, background images. kernels and initrds are correcty
loaded.

This is the first time I do something non-trivial in scheme, so there
might be an easier way to achieve the same result. Nonetheless, I have
tested it on my system and seems to work ok.

* guix/scripts/system.scm (previous-grub-entries): resolve initrd
  symlink for old entries (on the host).
* gnu/system.scm (operating-system-grub.cfg): resolve initrd symlink for
  current system (on the container).
* gnu/system/grub.scm: strip mount-point from GRUB filenames.

---
 gnu/system.scm          |  2 +-
 gnu/system/grub.scm     | 29 ++++++++++++++++++++---------
 guix/scripts/system.scm |  6 +++---
 3 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index 0802010..1346f49 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -723,7 +723,7 @@ listed in OS.  The C library expects to find it under
                                    #~(string-append "--load=" #$system
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
-                           (initrd #~(string-append #$system "/initrd"))))))
+                           (initrd #~(readlink (string-append #$system "/initrd")))))))
     (grub-configuration-file (operating-system-bootloader os)
                              store-fs entries
                              #:old-entries old-entries)))
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..56cb081 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -62,6 +62,14 @@
 ;;;
 ;;; Code:
 
+(define (strip-mount-point fs file)
+  (let ((mount-point (file-system-mount-point fs)))
+    (if (string=? mount-point "/")
+	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 +191,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
+		       #~(string-append #$grub "/share/grub/unicode.pf2")))
 
   (mlet* %store-monad ((image (grub-background-image config)))
     (return (and image
@@ -209,7 +218,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))))))
 
@@ -254,17 +263,19 @@ corresponding to old generations of the system."
   (define entry->gexp
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
-      #~(format port "menuentry ~s {
+      (let ((linux (strip-mount-point store-fs linux))
+            (initrd (strip-mount-point store-fs initrd)))
+        #~(format port "menuentry ~s {
   ~a
   linux ~a/~a ~a
   initrd ~a
 }~%"
-                #$label
-                #$(grub-root-search store-fs
-                                    #~(string-append #$linux "/"
-                                                     #$linux-image-name))
-                #$linux #$linux-image-name (string-join (list #$@arguments))
-                #$initrd))))
+                  #$label
+                  #$(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 store-fs system #~port)))
     (define builder
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 953c624..5ff98a0 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -391,10 +391,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 (readlink (string-append system "/initrd")))))))
 
   (let* ((numbers (generation-numbers profile))
          (systems (map (cut generation-file-name profile <>)
-- 

      parent reply	other threads:[~2016-09-13 11:24 UTC|newest]

Thread overview: 12+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2016-08-24  7:06 Store on separate partition Carlos Sánchez de La Lama
2016-08-24  7:35 ` Vincent Legoll
2016-08-24  8:18 ` Alex Kost
2016-08-24 10:37   ` Carlos Sánchez de La Lama
2016-08-25 14:30     ` Tomáš Čech
2016-08-25 22:04       ` Tomáš Čech
2016-08-29 16:15   ` Ludovic Courtès
2016-08-31 12:48     ` Carlos Sánchez de La Lama
2016-08-31 21:21       ` Ludovic Courtès
2016-09-01  4:34         ` John Darrington
2016-09-01  6:35           ` Vincent Legoll
2016-09-13 11:23       ` Carlos Sánchez de La Lama [this message]

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=7toa3s11sc.fsf@gmail.com \
    --to=csanchezdll@gmail.com \
    --cc=24344@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.