From patchwork Fri Oct 28 10:07:20 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Chris Marusich X-Patchwork-Id: 16895 Received: (qmail 124927 invoked by uid 89); 28 Oct 2016 10:10:22 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Checked: by ClamAV 0.99.2 on sourceware.org X-Virus-Found: No X-Spam-SWARE-Status: No, score=-3.3 required=5.0 tests=BAYES_00, FREEMAIL_FROM, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 spammy=colors, resort X-Spam-Status: No, score=-3.3 required=5.0 tests=BAYES_00, FREEMAIL_FROM, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on sourceware.org X-Spam-Level: X-HELO: lists.gnu.org Received: from lists.gnu.org (HELO lists.gnu.org) (208.118.235.17) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 28 Oct 2016 10:10:20 +0000 Received: from localhost ([::1]:47963 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c0478-00069h-Sl for patchwork@sourceware.org; Fri, 28 Oct 2016 06:10:18 -0400 Received: from eggs.gnu.org ([2001:4830:134:3::10]:56768) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c044l-0004Rk-68 for guix-devel@gnu.org; Fri, 28 Oct 2016 06:07:56 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1c044j-0003yf-C2 for guix-devel@gnu.org; Fri, 28 Oct 2016 06:07:51 -0400 Received: from mail-pf0-x244.google.com ([2607:f8b0:400e:c00::244]:33564) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1c044i-0003y6-Tr for guix-devel@gnu.org; Fri, 28 Oct 2016 06:07:49 -0400 Received: by mail-pf0-x244.google.com with SMTP id i85so872195pfa.0 for ; Fri, 28 Oct 2016 03:07:48 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=y1tRafVk2J9hdvNQpN3I8KYBq42qKW/YWDrY5T+8+V0=; b=W+LpLybHG2aytUfs8cmncymBnhofibcI81dlZHKu65tkshVG66LwmziwP1V7sPWY4S 2jMGAMZyQN6+ScwQ3pwclpHJvk9r9Ft4ZBSJi5Gk8LVz31LV84p7KgrkFCP+AXq1++g1 gj6wz+WbEcdeuVDAmD+b6aY4hwU8+aZDldrWX/NOJXNDAGGbihvMfg8cLA4y0W3XDQ6R GM8+fC3EA9jdd6EFPt5PGK3Hu8wL2qQF3OPa1cWBoxymWWaGhMNuCx49kxoEGv5MmabD lWKW8TDehZt68sTiYhEEAlsnNvhXeBDO0Fffgb5JzURuf1aO1GYBwLLIP3tG/xRpRNJg MK1Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20130820; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=y1tRafVk2J9hdvNQpN3I8KYBq42qKW/YWDrY5T+8+V0=; b=LCs5ztbGAJrQHfsHHG1nJ5gPr9XisqBlnDqsqgGV3lngOcIWpYHF0rMiuKCly8S4Md kp09R3L/4+lFTqHL1aDAuTC/II1EuW0T9ucg8mppdGGq1YMqSJSDZFz+5pe/G7k0G5Af XBFIhzGE0u/E/TaUyUxAflBr+00lPAbqgoCS5n2osDBzuGnJ+8rca/lZ2nh8PleEJnrc fB4SBZlmzFuqyw/zOuDZrnnpdF0bxfNUYZV/n7ivvO2SgmDghpAcreLR858eIFwWOmSe a5EDbOumNzB42V88xpBg3KgLpAztg/Ctnoc5Es3xgsbTa5MUlpzZb0jiZOwWyl2uGrso /bTg== X-Gm-Message-State: ABUngveToRjkFcdWxI1QesQfVxsjfz0qMQay42BTbn19Hsznq3nqXCIi2WHKJKr9lRF3Eg== X-Received: by 10.98.66.149 with SMTP id h21mr23339498pfd.32.1477649267389; Fri, 28 Oct 2016 03:07:47 -0700 (PDT) Received: from garuda.hsd1.wa.comcast.net. ([2601:602:9d80:188d:4e0f:6eff:fef6:70b9]) by smtp.gmail.com with ESMTPSA id t7sm17798508pfa.22.2016.10.28.03.07.46 (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Fri, 28 Oct 2016 03:07:46 -0700 (PDT) From: cmmarusich@gmail.com To: guix-devel@gnu.org Subject: [PATCH 03/10] Refactor grub.cfg generation logic Date: Fri, 28 Oct 2016 03:07:20 -0700 Message-Id: <20161028100727.1182-4-cmmarusich@gmail.com> X-Mailer: git-send-email 2.10.1 In-Reply-To: <20161028100727.1182-1-cmmarusich@gmail.com> References: <20161028100727.1182-1-cmmarusich@gmail.com> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2607:f8b0:400e:c00::244 X-BeenThere: guix-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+patchwork=sourceware.org@gnu.org Sender: "Guix-devel" From: Chris Marusich This enables the implementation of 'guix system switch-generation' and 'guix system roll-back'. Those new commands will only be able to determine the store device and mount point for a given system generation by reading them from that generation's boot parameters file, which does not contain a object. This change makes it possible for those commands regenerate grub.cfg using that information. * gnu/system.scm (operating-system-grub.cfg): Instead of passing store-fs directly as a parameter to grub-configuration-file, pass in its mount point and (basically) its device. * gnu/system/grub.scm (strip-mount-point, eye-candy, grub-root-search, grub-configuration-file, previous-grub-entries): Refactor these procedures to take a mount point and/or (basically) a device as parameters instead of a full-fledged object. --- gnu/system.scm | 10 ++++- gnu/system/grub.scm | 98 ++++++++++++++++++++++++++----------------------- guix/scripts/system.scm | 3 +- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index f9f63a0..0d8c25a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -728,6 +728,10 @@ listed in OS. The C library expects to find it under ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) (store-fs -> (operating-system-store-file-system os)) + (grub-root-search-device -> (case (file-system-title store-fs) + ((uuid) (file-system-device store-fs)) + ((label) (file-system-device store-fs)) + (else #f))) (label -> (kernel->grub-label (operating-system-kernel os))) (kernel -> (operating-system-kernel-file os)) (initrd (operating-system-initrd-file os)) @@ -736,7 +740,7 @@ listed in OS. The C library expects to find it under (file-system-device root-fs))) (entries -> (list (menu-entry (label label) - (device #f) ;; stub value, not used yet + (device grub-root-search-device) (linux kernel) (linux-arguments (cons* (string-append "--root=" root-device) @@ -746,7 +750,9 @@ listed in OS. The C library expects to find it under (operating-system-kernel-arguments os))) (initrd initrd))))) (grub-configuration-file (operating-system-bootloader os) - store-fs entries + (file-system-mount-point store-fs) + grub-root-search-device + entries #:old-entries old-entries))) (define (operating-system-parameters-file os) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 859f33a..d45fdca 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -62,16 +62,15 @@ ;;; ;;; Code: -(define (strip-mount-point fs file) - "Strip the mount point of FS from FILE, which is a gexp or other lowerable +(define (strip-mount-point mount-point file) + "Strip MOUNT-POINT 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))))) + (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 make-grub-image @@ -164,12 +163,15 @@ WIDTH/HEIGHT, or #f if none was found." (with-monad %store-monad (return #f))))) -(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. 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 (eye-candy config store-fs-mount-point store-device system port) + "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part +concerned with graphics mode, background images, colors, and all that. +STORE-FS-MOUNT-POINT is the mount point of the file system containing the +store. STORE-DEVICE is a file system UUID, a file system label, or #f. The +value of STORE-DEVICE determines the GRUB search command that will be used to +find and set the GRUB root; for details, please refer to the +'grub-root-search' procedure's docstring. 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 @@ -193,7 +195,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-fs-mount-point (file-append grub "/share/grub/unicode.pf2"))) (mlet* %store-monad ((image (grub-background-image config))) @@ -201,7 +203,7 @@ the store is. SYSTEM must be the target system string---e.g., #~(format #$port " function setup_gfxterm {~a} -# Set 'root' to the partition that contains /gnu/store. +# Set GRUB's 'root' to the device that contains the store. ~a if loadfont ~a; then @@ -217,10 +219,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-fs-mount-point image) #$(theme-colors grub-theme-color-normal) #$(theme-colors grub-theme-color-highlight)))))) @@ -229,57 +231,63 @@ fi~%" ;;; Configuration file. ;;; -(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 +(define (grub-root-search device file) + "Return a GRUB 'search' command (@pxref{search,,, grub, GNU GRUB manual}) +which will find the device indicated by DEVICE and which will set GRUB's +'root' to it (@pxref{root,,, grub, GNU GRUB manual}). DEVICE may be a file +system UUID or label, in which case the search command will find the device +containing the specified file system and set the root to it, or it may be #f, +in which case the search command will find the device containing the specified +FILE. The result is a gexp that can be inserted into grub.cfg-generation code." ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of ;; 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 - ;; 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))) + (cond ((and (string? file) (not (string-prefix? "/" file))) + "") + ((not device) + #~(format #f "search --file --set ~a" #$file)) + ((string? device) + (format #f "search --label --set ~a" device)) (else - ;; As a last resort, look for any device containing FILE. - #~(format #f "search --file --set ~a" #$file))))) + (format #f "search --fs-uuid --set ~a" (uuid->string device))))) -(define* (grub-configuration-file config store-fs entries +(define* (grub-configuration-file config + store-fs-mount-point + store-device + entries #:key (system (%current-system)) (old-entries '())) "Return the GRUB configuration file corresponding to CONFIG, a - object, and where the store is available at STORE-FS, a - object. OLD-ENTRIES is taken to be a list of menu entries -corresponding to old generations of the system." + object. STORE-FS-MOUNT-POINT is the mount point of the +file system containing the store. STORE-DEVICE is a file system UUID, a file +system label, or #f. The value of STORE-DEVICE determines the GRUB search +command that will be used to find and set the GRUB root; for details, please +refer to the 'grub-root-search' procedure's docstring. OLD-ENTRIES is taken +to be a list of menu entries corresponding to old generations of the system." (define all-entries (append entries (grub-configuration-menu-entries config))) (define entry->gexp (match-lambda (($ label device 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))) + ;; Use the right paths in case the file system containing the store is + ;; not mounted at "/". + (let ((linux (strip-mount-point store-fs-mount-point linux)) + (initrd (strip-mount-point store-fs-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 store-fs-mount-point store-device system #~port))) (define builder #~(call-with-output-file #$output (lambda (port) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8f0b8cd..4edaa0f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -375,6 +375,7 @@ it atomically, and then run OS's activation script." read-boot-parameters)) (label (boot-parameters-label params)) (root (boot-parameters-root-device params)) + (store (boot-parameters-store-device params)) (root-device (if (bytevector? root) (uuid->string root) root)) @@ -385,7 +386,7 @@ it atomically, and then run OS's activation script." (label (string-append label " (#" (number->string number) ", " (seconds->string time) ")")) - (device #f) ; stub value, not used yet + (device store) (linux kernel) (linux-arguments (cons* (string-append "--root=" root-device)