From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:44228) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cufxK-0002VO-D3 for guix-patches@gnu.org; Sun, 02 Apr 2017 09:54:12 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cufxI-0000YD-E8 for guix-patches@gnu.org; Sun, 02 Apr 2017 09:54:10 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:58378) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cufxI-0000Xp-8d for guix-patches@gnu.org; Sun, 02 Apr 2017 09:54:08 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1cufxI-0000ci-1s for guix-patches@gnu.org; Sun, 02 Apr 2017 09:54:08 -0400 Subject: bug#26339: [PATCH 15/18] scripts: system: Adapt "reconfigure" to new bootloader API. Resent-Message-ID: From: Mathieu Othacehe Date: Sun, 2 Apr 2017 15:52:39 +0200 Message-Id: <20170402135242.2958-15-m.othacehe@gmail.com> In-Reply-To: <20170402135242.2958-1-m.othacehe@gmail.com> References: <20170402135242.2958-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, "install-procedure" 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 | 116 ++++++++++++++++++++++++++++-------------------- 1 file changed, 69 insertions(+), 47 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 791cf1166..9f1d4f95c 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 install-procedure + #:key + bootcfg bootcfg-location + device target) + "Call INSTALL-PROCEDURE 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 install-procedure + (derivation->output-path install-procedure))) + (bootcfg (derivation->output-path bootcfg))) + ;; Prepare the symlink to bootloader config file to make sure that it's + ;; a GC root when 'install-procedure' completes (being a bit paranoid.) + (switch-symlinks temp-gc-root bootcfg) + + (unless (false-if-exception + (begin + (install-boot-config bootcfg bootcfg-location target) + (when install + (save-load-path-excursion (primitive-load install))))) (delete-file temp-gc-root) - (leave (_ "failed to install GRUB on device '~a'~%") device)) + (leave (_ "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)) @@ -579,16 +586,27 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (_ "Failing to do that may downgrade your system!~%")))) +(define (install-bootloader-derivation install-procedure + bootloader device target) + (with-monad %store-monad + (gexp->file "install-bootloader" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (#$install-procedure #$bootloader + #$device + #$target)))))) + (define* (perform-action action os #:key bootloader? dry-run? derivations-only? use-substitutes? device target image-size full-boot? (mappings '())) - "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." @@ -608,20 +626,28 @@ building anything." (if bootloader (package->derivation bootloader) (return #f)))) - (grub.cfg (if (eq? 'container action) - (return #f) - (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (profile-grub-entries))))) - - ;; 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 . + (bootcfg (if (eq? 'container action) + (return #f) + (operating-system-bootcfg + os + (if (eq? 'init action) + '() + (profile-bootloader-entries))))) + (bootcfg-location -> (bootloader-configuration-file-location + (operating-system-bootloader os))) + (install-proc + (let ((procedure (bootloader-configuration-install-procedure + (operating-system-bootloader os))) + (target (or target "/"))) + (install-bootloader-derivation procedure bootloader 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 grub? bootloader) - (list sys grub.cfg bootloader) - (list sys grub.cfg)) + (if (and bootloader? bootloader) + (list sys bootcfg bootloader install-proc) + (list sys bootcfg)) (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -635,20 +661,16 @@ building anything." (for-each (compose println derivation->output-path) drvs) - ;; Make sure GRUB is accessible. - (when (and grub? 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 grub? - (install-grub* (derivation->output-path grub.cfg) - device "/")))) + (mwhen bootloader? + (install-bootloader install-proc + #:bootcfg bootcfg + #:bootcfg-location bootcfg-location + #:device device + #:target "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") -- 2.12.2