From patchwork Wed Jul 24 16:34:38 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14755 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 2B2F81726B; Wed, 24 Jul 2019 17:38:09 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 7AF011726B for ; Wed, 24 Jul 2019 17:38:08 +0100 (BST) Received: from localhost ([::1]:53272 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hqKHI-0005l4-2F for patchwork@mira.cbaines.net; Wed, 24 Jul 2019 12:38:08 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:38047) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hqKHE-0005kq-Dx for guix-patches@gnu.org; Wed, 24 Jul 2019 12:38:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hqKHC-0003I1-DD for guix-patches@gnu.org; Wed, 24 Jul 2019 12:38:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:57350) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hqKHC-0003HX-7x for guix-patches@gnu.org; Wed, 24 Jul 2019 12:38:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hqKHC-0002MY-4Z for guix-patches@gnu.org; Wed, 24 Jul 2019 12:38:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v6 2/3] guix system: Reimplement 'reconfigure'. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 24 Jul 2019 16:38:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36555 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.15639862368990 (code B ref 36555); Wed, 24 Jul 2019 16:38:02 +0000 Received: (at 36555) by debbugs.gnu.org; 24 Jul 2019 16:37:16 +0000 Received: from localhost ([127.0.0.1]:37935 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hqKGS-0002Kv-1k for submit@debbugs.gnu.org; Wed, 24 Jul 2019 12:37:16 -0400 Received: from mx.sdf.org ([205.166.94.20]:53435) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hqKGQ-0002Ko-Kv for 36555@debbugs.gnu.org; Wed, 24 Jul 2019 12:37:15 -0400 Received: from Epsilon (pool-173-76-53-40.bstnma.fios.verizon.net [173.76.53.40]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x6OGbCVx010358 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Wed, 24 Jul 2019 16:37:13 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87pnmc7nt1.fsf@gnu.org> <8736j7nwcb.fsf@sdf.lonestar.org> <87muhfjm14.fsf@gnu.org> <87ftn63l7d.fsf@sdf.lonestar.org> <87v9w1zgon.fsf_-_@sdf.lonestar.org> <87y30v3qke.fsf@sdf.lonestar.org> <871rylrjt8.fsf_-_@sdf.lonestar.org> <87wogdq575.fsf_-_@sdf.lonestar.org> <87r26lq531.fsf_-_@sdf.lonestar.org> <87muh9q51e.fsf_-_@sdf.lonestar.org> <87wogc4v6e.fsf@gnu.org> <87zhl69box.fsf@sdf.lonestar.org> <87o91laojb.fsf_-_@sdf.lonestar.org> <87k1c9aofq.fsf_-_@sdf.lonestar.org> <87ftmxaodv.fsf_-_@sdf.lonestar.org> <87ftmwz8mc.fsf@gnu.org> <877e889tyj.fsf@sdf.lonestar.org> <87tvbc8dgi.fsf@sdf.lonestar.org> <87muh3bdf4.fsf_-_@sdf.lonestar.org> <87imrrbddx.fsf_-_@sdf.lonestar.org> Date: Wed, 24 Jul 2019 12:34:38 -0400 In-Reply-To: <87imrrbddx.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Wed, 24 Jul 2019 12:34:02 -0400") Message-ID: <87ef2fbdcx.fsf_-_@sdf.lonestar.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: 36555@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/system.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Delete variable. (local-eval): New variable. (install): Remove 'bootloader-installer' and 'bootcfg-file' parameters. (install): Add 'bootloader' parameter. --- guix/scripts/system.scm | 188 +++++++++------------------------------- 1 file changed, 41 insertions(+), 147 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 67a4071684..115da665b4 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -41,6 +41,7 @@ delete-matching-generations) #:use-module (guix graph) #:use-module (guix scripts graph) + #:use-module (guix scripts system reconfigure) #:use-module (guix build utils) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (terminal-columns)) @@ -178,43 +179,9 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer - #:key - bootcfg bootcfg-file - target) - "Run INSTALLER, a bootloader installation script, with error handling, in -%STORE-MONAD." - (mlet %store-monad ((installer-drv (if installer - (lower-object installer) - (return #f))) - (bootcfg (lower-object bootcfg))) - (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 bootloader ~a~%") install)) - - ;; 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)) - bootloader-installer install-bootloader? - bootcfg bootcfg-file) + install-bootloader? bootloader bootcfg) "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what 'register-path' expects. @@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%") (populate os-dir target) (mwhen install-bootloader? - (install-bootloader bootloader-installer - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target)))))) + (install-bootloader local-eval bootloader bootcfg + #:target target) + (return + (info (G_ "bootloader successfully installed on '~a'~%") + (bootloader-configuration-target bootloader)))))))) ;;; @@ -335,82 +303,6 @@ unload." (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) -(define (upgrade-shepherd-services os) - "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new -services specified in OS and not currently running. - -This is currently very conservative in that it does not stop or unload any -running service. Unloading or stopping the wrong service ('udev', say) could -bring the system down." - (define new-services - (service-value - (fold-services (operating-system-services os) - #:target-type shepherd-root-service-type))) - - ;; Arrange to simply emit a warning if the service upgrade fails. - (with-shepherd-error-handling - (call-with-service-upgrade-info new-services - (lambda (to-restart to-unload) - (for-each (lambda (unload) - (info (G_ "unloading service '~a'...~%") unload) - (unload-service unload)) - to-unload) - - (with-monad %store-monad - (munless (null? new-services) - (let ((new-service-names (map shepherd-service-canonical-name new-services)) - (to-restart-names (map shepherd-service-canonical-name to-restart)) - (to-start (filter shepherd-service-auto-start? new-services))) - (info (G_ "loading new services:~{ ~a~}...~%") new-service-names) - (unless (null? to-restart-names) - ;; Listing TO-RESTART-NAMES in the message below wouldn't help - ;; because many essential services cannot be meaningfully - ;; restarted. See . - (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop, -upgrade, and restart each service that was not automatically restarted.\n"))) - (mlet %store-monad ((files (mapm %store-monad - (compose lower-object - shepherd-service-file) - new-services))) - ;; Here we assume that FILES are exactly those that were computed - ;; as part of the derivation that built OS, which is normally the - ;; case. - (load-services/safe (map derivation->output-path files)) - - (for-each start-service - (map shepherd-service-canonical-name to-start)) - (return #t))))))))) - -(define* (switch-to-system os - #:optional (profile %system-profile)) - "Make a new generation of PROFILE pointing to the directory of OS, switch to -it atomically, and then run OS's activation script." - (mlet* %store-monad ((drv (operating-system-derivation os)) - (script (lower-object (operating-system-activation-script os)))) - (let* ((system (derivation->output-path drv)) - (number (+ 1 (generation-number profile))) - (generation (generation-file-name profile number))) - (switch-symlinks generation system) - (switch-symlinks profile generation) - - (format #t (G_ "activating system...~%")) - - ;; The activation script may change $PATH, among others, so protect - ;; against that. - (save-environment-excursion - ;; Tell 'activate-current-system' what the new system is. - (setenv "GUIX_NEW_SYSTEM" system) - - ;; The activation script may modify '%load-path' & co., so protect - ;; against that. This is necessary to ensure that - ;; 'upgrade-shepherd-services' gets to see the right modules when it - ;; computes derivations with 'gexp->derivation'. - (save-load-path-excursion - (primitive-load (derivation->output-path script)))) - - ;; Finally, try to update system services. - (upgrade-shepherd-services os)))) - (define-syntax-rule (unless-file-not-found exp) (catch 'system-error (lambda () @@ -505,18 +397,13 @@ STORE is an open connection to the store." ((bootloader-configuration-file-generator bootloader) bootloader-config entries #:old-entries old-entries))) - (bootcfg-file -> (bootloader-configuration-file bootloader)) - (target -> "/") (drvs -> (list bootcfg))) (mbegin %store-monad (show-what-to-build* drvs) (built-derivations drvs) - ;; Only install bootloader configuration file. Thus, no installer is - ;; provided here. - (install-bootloader #f - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target)))))) + ;; Only install bootloader configuration file. + (install-bootloader local-eval bootloader-config bootcfg + #:run-installer? #f)))))) ;;; @@ -820,8 +707,17 @@ and TARGET arguments." (condition-message c)) (exit 1))) (#$installer #$bootloader #$device #$target) - (format #t "bootloader successfully installed on '~a'~%" - #$device)))))) + (info (G_ "bootloader successfully installed on '~a'~%") + #$device)))))) + +(define (local-eval exp) + "Evaluate EXP, a G-Expression, in-place." + (mlet* %store-monad ((lowered (lower-gexp exp)) + (_ (built-derivations (lowered-gexp-inputs lowered)))) + (save-load-path-excursion + (set! %load-path (lowered-gexp-load-path lowered)) + (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) + (return (primitive-eval (lowered-gexp-sexp lowered)))))) (define* (perform-action action os #:key skip-safety-checks? @@ -858,19 +754,12 @@ static checks." (map boot-parameters->menu-entry (profile-boot-parameters)))) (define bootloader - (bootloader-configuration-bootloader (operating-system-bootloader os))) + (operating-system-bootloader os)) (define bootcfg (and (memq action '(init reconfigure)) (operating-system-bootcfg os menu-entries))) - (define bootloader-script - (let ((installer (bootloader-installer bootloader)) - (target (or target "/"))) - (bootloader-installer-script installer - (bootloader-package bootloader) - bootloader-target target))) - (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) @@ -897,9 +786,7 @@ static checks." ;; See . (drvs (mapm %store-monad lower-object (if (memq action '(init reconfigure)) - (if install-bootloader? - (list sys bootcfg bootloader-script) - (list sys bootcfg)) + (list sys bootcfg) (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -909,28 +796,35 @@ static checks." (if (or dry-run? derivations-only?) (return #f) - (let ((bootcfg-file (bootloader-configuration-file bootloader))) + (begin (for-each (compose println derivation->output-path) drvs) (case action ((reconfigure) - (mbegin %store-monad - (switch-to-system os) - (mwhen install-bootloader? - (install-bootloader bootloader-script - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target "/")))) + (newline) + (format #t (G_ "activating system...~%")) + (guard (c ((message-condition? c) + (leave (G_ "failed to reconfigure system:~%~a~%") + (condition-message c)))) + (mbegin %store-monad + (switch-to-system local-eval os) + (mwhen install-bootloader? + (install-bootloader local-eval bootloader bootcfg + #:target (or target "/")) + (return + (info (G_ "bootloader successfully installed on '~a'~%") + (bootloader-configuration-target bootloader)))) + (with-shepherd-error-handling + (upgrade-shepherd-services local-eval os))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") target) (install sys (canonicalize-path target) #:install-bootloader? install-bootloader? - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:bootloader-installer bootloader-script)) + #:bootloader bootloader + #:bootcfg bootcfg)) (else ;; All we had to do was to build SYS and maybe register an ;; indirect GC root.