From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:38345) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d9oH5-0000Wx-Ou for guix-patches@gnu.org; Sun, 14 May 2017 03:49:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d9oH2-0007kb-Dc for guix-patches@gnu.org; Sun, 14 May 2017 03:49:07 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40849) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d9oH2-0007kJ-AO for guix-patches@gnu.org; Sun, 14 May 2017 03:49:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d9oH2-0003vD-1i for guix-patches@gnu.org; Sun, 14 May 2017 03:49:04 -0400 Subject: bug#26339: [PATCH v4 4/7] scripts: system: Adapt "reconfigure" to new bootloader API. Resent-Message-ID: From: Mathieu Othacehe Date: Sun, 14 May 2017 09:48:00 +0200 Message-Id: <20170514074803.25556-5-m.othacehe@gmail.com> In-Reply-To: <20170514074803.25556-1-m.othacehe@gmail.com> References: <20170514074803.25556-1-m.othacehe@gmail.com> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26339@debbugs.gnu.org * guix/scripts/system.scm (install-grub*): Rename to install-bootloader. Use keys to pass arguments. Pass a new argument, "installer.drv" which is a script in store dealing with bootloader-specific install actions. Also call "install-boot-config" to install the bootloader config file. (install-bootloader-derivation): New procedure. It returns a derivation that builds a file containing "install-procedure" gexp. (perform-action): Build install-proc derivation and call install-bootloader with the resulting file. Stop adding GRUB to PATH as bootloaders are called in install-proc with direct store paths. --- guix/scripts/system.scm | 129 +++++++++++++++++++++++++++++------------------- 1 file changed, 77 insertions(+), 52 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5fd0d7600..b194b59a7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -147,27 +147,34 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) -(define (install-grub* grub.cfg device target) - "This is a variant of 'install-grub' with error handling, lifted in -%STORE-MONAD" - (let* ((gc-root (string-append target %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 (false-if-exception (install-grub grub.cfg device target)) +(define* (install-bootloader installer.drv + #:key + bootcfg bootcfg-file + device target) + "Call INSTALLER.DRV with error handling, in %STORE-MONAD." + (with-monad %store-monad + (let* ((gc-root (string-append target %gc-roots-directory + "/bootcfg")) + (temp-gc-root (string-append gc-root ".new")) + (install (and installer.drv + (derivation->output-path installer.drv))) + (bootcfg (derivation->output-path bootcfg))) + ;; Prepare the symlink to bootloader config file to make sure that it's + ;; a GC root when 'installer.drv' completes (being a bit paranoid.) + (switch-symlinks temp-gc-root bootcfg) + + (unless (false-if-exception + (begin + (install-boot-config bootcfg bootcfg-file target) + (when install + (save-load-path-excursion (primitive-load install))))) (delete-file temp-gc-root) - (leave (G_ "failed to install GRUB on device '~a'~%") device)) + (leave (G_ "failed to install bootloader on device ~a '~a'~%") install device)) - ;; Register GRUB.CFG as a GC root so that its dependencies (background - ;; image, font, etc.) are not reclaimed. - (rename temp-gc-root gc-root)))) + ;; Register bootloader config file as a GC root so that its dependencies + ;; (background image, font, etc.) are not reclaimed. + (rename-file temp-gc-root gc-root) + (return #t)))) (define* (install os-drv target #:key (log-port (current-output-port)) @@ -570,17 +577,28 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) +(define (bootloader-installer-derivation installer + bootloader device target) + "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE +and TARGET arguments." + (with-monad %store-monad + (gexp->file "bootloader-installer" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (#$installer #$bootloader #$device #$target)))))) + (define* (perform-action action os #:key bootloader? dry-run? derivations-only? use-substitutes? device target image-size full-boot? (mappings '()) (gc-root #f)) - "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is -the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE -is the size of the image to be built, for the 'vm-image' and 'disk-image' -actions. FULL-BOOT? is used for the 'vm' action; it determines whether to -boot directly to the kernel or to the bootloader. + "Perform ACTION for OS. BOOTLOADER? specifies whether to install +bootloader; DEVICE is the target devices for bootloader; TARGET is the target +root directory; IMAGE-SIZE is the size of the image to be built, for the +'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action; +it determines whether to boot directly to the kernel or to the bootloader. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -598,26 +616,37 @@ output when building a system derivation, such as a disk image." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (bootloader (let ((bootloader (bootloader-package - (bootloader-configuration-bootloader - (operating-system-bootloader os))))) - (if bootloader - (package->derivation bootloader) - (return #f)))) - (grub.cfg (if (eq? 'container action) - (return #f) - (operating-system-bootcfg os - (if (eq? 'init action) - '() - (profile-boot-parameters))))) - - ;; 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 - ;; root. See . + (bootloader -> (bootloader-configuration-bootloader + (operating-system-bootloader os))) + (bootloader-package + (let ((package (bootloader-package bootloader))) + (if package + (package->derivation package) + (return #f)))) + (bootcfg (if (eq? 'container action) + (return #f) + (operating-system-bootcfg + os + (if (eq? 'init action) + '() + (profile-boot-parameters))))) + (bootcfg-file -> (bootloader-configuration-file bootloader)) + (bootloader-installer + (let ((installer (bootloader-installer bootloader)) + (target (or target "/"))) + (bootloader-installer-derivation installer + bootloader-package + device target))) + + ;; For 'init' and 'reconfigure', always build BOOTCFG, even if + ;; --no-bootloader is passed, because we then use it as a GC root. + ;; See . (drvs -> (if (memq action '(init reconfigure)) - (if (and bootloader? bootloader) - (list sys grub.cfg bootloader) - (list sys grub.cfg)) + (if (and bootloader? bootloader-package) + (list sys bootcfg + bootloader-package + bootloader-installer) + (list sys bootcfg)) (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -631,20 +660,16 @@ output when building a system derivation, such as a disk image." (for-each (compose println derivation->output-path) drvs) - ;; Make sure GRUB is accessible. - (when (and bootloader? bootloader) - (let ((prefix (derivation->output-path bootloader))) - (setenv "PATH" - (string-append prefix "/bin:" prefix "/sbin:" - (getenv "PATH"))))) - (case action ((reconfigure) (mbegin %store-monad (switch-to-system os) (mwhen bootloader? - (install-grub* (derivation->output-path grub.cfg) - device "/")))) + (install-bootloader bootloader-installer + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:device device + #:target "/")))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") -- 2.13.0