From mboxrd@z Thu Jan 1 00:00:00 1970 From: Jookia <166291@gmail.com> Subject: [RFCv2] install: Create a GC root during install-grub. Date: Tue, 8 Mar 2016 18:59:16 +1100 Message-ID: <56de87dc.418f1c0a.cf798.ffff8aa3@mx.google.com> References: <56d7a6b8.8391700a.87f3c.ffffa7fe@mx.google.com> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:36166) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from <166291@gmail.com>) id 1adCeP-0003oR-BN for guix-devel@gnu.org; Tue, 08 Mar 2016 03:05:54 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from <166291@gmail.com>) id 1adCeM-0003ON-4D for guix-devel@gnu.org; Tue, 08 Mar 2016 03:05:53 -0500 Received: from mail-wm0-x22e.google.com ([2a00:1450:400c:c09::22e]:38568) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <166291@gmail.com>) id 1adCeL-0003OD-Nb for guix-devel@gnu.org; Tue, 08 Mar 2016 03:05:50 -0500 Received: by mail-wm0-x22e.google.com with SMTP id l68so16271197wml.1 for ; Tue, 08 Mar 2016 00:05:49 -0800 (PST) Received: from localhost (chomsky.torservers.net. [77.247.181.162]) by smtp.gmail.com with ESMTPSA id r62sm2059080wmd.15.2016.03.08.00.05.45 for (version=TLSv1/SSLv3 cipher=OTHER); Tue, 08 Mar 2016 00:05:48 -0800 (PST) In-Reply-To: <56d7a6b8.8391700a.87f3c.ffffa7fe@mx.google.com> 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+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org While previously creating a GC root for GRUB's resources was the caller's responsibility, it's much less repetitive to put it in install-grub now that it's wrapped by error handling. This also means we can replace the install-grub* function with a small definition inside perform-action named 'install-boot'. * gnu/build/install.scm (install-grub): Make a GC root for grub.cfg on success. (register-grub.cfg-root): Remove function, install-grub does this now. * gnu/system/vm.scm (qemu-image): Don't explicitly make a GC root. * guix/scripts/system.scm (install-grub*): Move useful parts to perform-action. (perform-action): Use inline definition install-boot to install GRUB. --- gnu/build/install.scm | 22 +++++++++------------- gnu/system/vm.scm | 15 +++++++-------- guix/scripts/system.scm | 47 +++++++++++++---------------------------------- 3 files changed, 29 insertions(+), 55 deletions(-) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index e4f087f..b28dea8 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -22,7 +22,6 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub - register-grub.cfg-root populate-root-file-system reset-timestamps register-closure @@ -39,13 +38,10 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. - -Note that the caller must make sure that GRUB.CFG is registered as a GC root -so that the fonts, background images, etc. referred to by GRUB.CFG are not -GC'd." +MOUNT-POINT." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) - (pivot (string-append target ".new"))) + (pivot (string-append target ".new")) + (gcroot "/var/guix/gcroots")) (mkdir-p (dirname target)) ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't @@ -57,13 +53,13 @@ GC'd." "--boot-directory" (string-append mount-point "/boot") device)) - (error "failed to install GRUB")))) + (error "failed to install GRUB")) -(define (register-grub.cfg-root target grub.cfg) - "On file system TARGET, register GRUB.CFG as a GC root." - (let ((directory (string-append target "/var/guix/gcroots"))) - (mkdir-p directory) - (symlink grub.cfg (string-append directory "/grub.cfg")))) + ;; Register GRUB.CFG as a GC root so the fonts, background images, etc. + ;; referred to by GRUB.CFG are not GC'd. + (evaluate-populate-directive `(directory ,gcroot) mount-point) + (evaluate-populate-directive + `(,(string-append gcroot "/grub.cfg") -> ,grub.cfg) mount-point))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 35c573d..e8a577c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -228,14 +228,13 @@ the image." (guix build utils)) (define* (do-install-grub #:key device target) - (and #$(prepare-install-grub - #:mount-point 'target - #:grub.cfg grub.cfg - #:config - (grub-configuration - (inherit (operating-system-bootloader os-configuration)) - (device drive))) - (register-grub.cfg-root target #$grub.cfg))) + #$(prepare-install-grub + #:mount-point 'target + #:grub.cfg grub.cfg + #:config + (grub-configuration + (inherit (operating-system-bootloader os-configuration)) + (device drive)))) (let ((inputs '#$(append (list qemu parted grub e2fsprogs) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4374a10..f3a10a5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -125,32 +125,6 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) -(define* (install-grub* #:key grub.cfg config target) - "This is a variant of 'install-grub' with error handling, lifted in -%STORE-MONAD" - (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) - (temp-gc-root (string-append gc-root ".new")) - (delete-file (lift1 delete-file %store-monad)) - (make-symlink (lift2 switch-symlinks %store-monad)) - (rename (lift2 rename-file %store-monad))) - (mbegin %store-monad - ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when - ;; 'install-grub' completes (being a bit paranoid.) - (make-symlink temp-gc-root grub.cfg) - - (munless (eval (prepare-install-grub - #:grub.cfg grub.cfg - #:config config - #:mount-point target) - (current-module)) - (delete-file temp-gc-root) - (leave (_ "failed to install GRUB on device '~a'~%") - (grub-configuration-device config))) - - ;; Register GRUB.CFG as a GC root so that its dependencies (background - ;; image, font, etc.) are not reclaimed. - (rename temp-gc-root gc-root)))) - (define* (install os-drv target grub.cfg #:key (log-port (current-output-port))) "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to @@ -487,6 +461,7 @@ building anything." (if (eq? 'init action) '() (previous-grub-entries))))) + (grub-config -> (operating-system-bootloader os)) ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC @@ -502,6 +477,16 @@ building anything." (maybe-build drvs #:dry-run? dry-run? #:use-substitutes? use-substitutes?)))) + (define (install-boot mount-point) + (mbegin %store-monad + (munless (eval (prepare-install-grub + #:grub.cfg (derivation->output-path grub.cfg) + #:config grub-config + #:mount-point mount-point) + (current-module)) + (leave (_ "failed to install GRUB on device '~a'~%") + (grub-configuration-device grub-config))))) + (if (or dry-run? derivations-only?) (return #f) (begin @@ -520,10 +505,7 @@ building anything." (mbegin %store-monad (switch-to-system os) (mwhen grub? - (install-grub* - #:grub.cfg (derivation->output-path grub.cfg) - #:config (operating-system-bootloader os) - #:target "/")))) + (install-boot "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") @@ -532,10 +514,7 @@ building anything." (install sys (canonicalize-path target) (derivation->output-path grub.cfg)) (mwhen grub? - (install-grub* - #:grub.cfg (derivation->output-path grub.cfg) - #:config (operating-system-bootloader os) - #:target target)))) + (install-boot mount-point)))) (else ;; All we had to do was to build SYS. (return (derivation->output-path sys)))))))) -- 2.7.0