From patchwork Fri Jul 5 23:46:44 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14483 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 35DAD171C0; Sat, 6 Jul 2019 00:48:19 +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 AF923171A5 for ; Sat, 6 Jul 2019 00:48:18 +0100 (BST) Received: from localhost ([::1]:57016 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXwA-0007Ve-DQ for patchwork@mira.cbaines.net; Fri, 05 Jul 2019 19:48:18 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:42333) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXvw-0007Oo-Py for guix-patches@gnu.org; Fri, 05 Jul 2019 19:48:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjXvu-0005Md-J8 for guix-patches@gnu.org; Fri, 05 Jul 2019 19:48:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:45166) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjXvu-0005MX-FY for guix-patches@gnu.org; Fri, 05 Jul 2019 19:48:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjXvu-0007do-AP for guix-patches@gnu.org; Fri, 05 Jul 2019 19:48:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 05 Jul 2019 23:48:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36404 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156237042829288 (code B ref 36404); Fri, 05 Jul 2019 23:48:02 +0000 Received: (at 36404) by debbugs.gnu.org; 5 Jul 2019 23:47:08 +0000 Received: from localhost ([127.0.0.1]:53986 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXv1-0007cK-Ix for submit@debbugs.gnu.org; Fri, 05 Jul 2019 19:47:08 -0400 Received: from mx.sdf.org ([205.166.94.20]:51005) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXuy-0007c9-6X for 36404@debbugs.gnu.org; Fri, 05 Jul 2019 19:47:05 -0400 Received: from Upsilon (mobile-166-171-185-104.mycingular.net [166.171.185.104]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x65Nkoxq002677 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 5 Jul 2019 23:46:56 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87r2799tzd.fsf@sdf.lonestar.org> <87d0isrsmk.fsf@sdf.lonestar.org> <878std3fw0.fsf@sdf.lonestar.org> <87wogwoqrg.fsf@gnu.org> <87bly8f3kq.fsf_-_@sdf.lonestar.org> Date: Fri, 05 Jul 2019 19:46:44 -0400 In-Reply-To: <87bly8f3kq.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:45:41 -0400") Message-ID: <877e8wf3iz.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: 36404@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/reconfigure.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/system.scm (bootloader-installer-script): Export variable. --- Makefile.am | 1 + guix/scripts/system.scm | 1 + guix/scripts/system/reconfigure.scm | 157 ++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+) create mode 100644 guix/scripts/system/reconfigure.scm diff --git a/Makefile.am b/Makefile.am index 4d3024e58..1934a21b1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -245,6 +245,7 @@ MODULES = \ guix/scripts/describe.scm \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ + guix/scripts/system/reconfigure.scm \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/crate.scm \ diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 60c1ca5c9..21858ee7d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -70,6 +70,7 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system + bootloader-installer-script read-operating-system)) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm new file mode 100644 index 000000000..f4ca6b4b1 --- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,157 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts system reconfigure) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (switch-to-system + upgrade-shepherd-services + install-bootloader)) + +;;; Commentary: +;;; +;;; This module implements the "effectful" parts of system +;;; reconfiguration. Although building a system derivation is a pure +;;; operation, a number of impure operations must be carried out for the +;;; system configuration to be realized -- chiefly, creation of generation +;;; symlinks and invocation of activation scripts. +;;; +;;; Code: + +(define (switch-to-system system-derivation activation-script) + "Return a G-Expression that, upon being evaluated, will create a new +generation for SYSTEM-DERIVATION and execute ACTIVATION-SCRIPT." + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles) + (guix utils))) + #~(begin + (use-modules (guix config) + (guix profiles) + (guix utils)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (let* ((system #$system-derivation) + (number (1+ (generation-number %system-profile))) + (generation (generation-file-name %system-profile number))) + (switch-symlinks generation system) + (switch-symlinks %system-profile generation) + ;; The implementation of 'guix system reconfigure' saves the + ;; load path and environment here. This is unnecessary here + ;; because each invocation of 'remote-eval' runs in a distinct + ;; Guile REPL. + (setenv "GUIX_NEW_SYSTEM" system) + ;; The activation script may write to stdout, which confuses + ;; 'remote-eval' when it attempts to read a result from the + ;; remote REPL. We work around this by forcing the output to a + ;; string. + (with-output-to-string + (lambda () + (primitive-load #$activation-script)))))))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; for details. +(define (upgrade-shepherd-services target-services) + "Return a G-Expression that, upon being evaluated, will use TARGET-SERVICES, +a list of (shepherd-service-canonical-name, shepherd-service-file) pairs to +determine which services are obsolete and need to be unloaded, as well as +which services are new and need to be started." + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (define running + (filter live-service-running (current-services))) + + (define (essential? service) + ;; Return #t if SERVICE is essential and should not be unloaded + ;; under any circumstance. + (memq (first (live-service-provision service)) + '(root shepherd))) + + (define (obsolete? service) + ;; Return #t if SERVICE can be safely unloaded. + (and (not (essential? service)) + (every (lambda (requirements) + (not (memq (first (live-service-provision service)) + requirements))) + (map live-service-requirement running)))) + + (define to-unload + (filter obsolete? + (remove (lambda (service) + (memq (first (live-service-provision service)) + (map first '#$target-services))) + running))) + + (define to-start + (remove (lambda (service-pair) + (memq (first service-pair) + (map (compose first live-service-provision) + running))) + '#$target-services)) + + ;; Unload obsolete services. + (for-each (lambda (service) + (false-if-exception + (unload-service service))) + to-unload) + + ;; Load the service files for any new services and start them. + (load-services/safe (map second to-start)) + (for-each start-service (map first to-start))))) + +(define (install-bootloader installer-script bootcfg bootcfg-file target) + "Return a G-Expression that, upon being evaluated, will install BOOTCFG to +BOOTCFG-FILE, a target path, on TARGET, a mount point, and subsequently run +INSTALLER-SCRIPT." + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build install) + (guix store) + (guix utils)) + (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + + (switch-symlinks temp-gc-root gc-root) + + (unless (false-if-exception + (begin + ;; The implementation of 'guix system reconfigure' + ;; saves the load path here. This is unnecessary here + ;; because each invocation of 'remote-eval' runs in a + ;; distinct Guile REPL. + (install-boot-config #$bootcfg #$bootcfg-file #$target) + ;; The installation script may write to stdout, which + ;; confuses 'remote-eval' when it attempts to read a + ;; result from the remote REPL. We work around this + ;; by forcing the output to a string. + (with-output-to-string + (lambda () + (primitive-load #$installer-script))))) + (delete-file temp-gc-root) + (error "failed to install bootloader")) + + (rename-file temp-gc-root gc-root)))))) From patchwork Fri Jul 5 23:47:50 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: 14484 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 58B5C171C0; Sat, 6 Jul 2019 00:49:12 +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 D1546171A5 for ; Sat, 6 Jul 2019 00:49:11 +0100 (BST) Received: from localhost ([::1]:57020 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXx1-0007fc-GE for patchwork@mira.cbaines.net; Fri, 05 Jul 2019 19:49:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:42465) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXwv-0007fD-DA for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjXwt-0005px-Ic for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:45172) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjXwt-0005pq-Fn for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjXwr-0007fi-UB for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 05 Jul 2019 23:49:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36404 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156237048329398 (code B ref 36404); Fri, 05 Jul 2019 23:49:01 +0000 Received: (at 36404) by debbugs.gnu.org; 5 Jul 2019 23:48:03 +0000 Received: from localhost ([127.0.0.1]:53990 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXvv-0007e6-9m for submit@debbugs.gnu.org; Fri, 05 Jul 2019 19:48:03 -0400 Received: from mx.sdf.org ([205.166.94.20]:50884) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXvq-0007dX-On for 36404@debbugs.gnu.org; Fri, 05 Jul 2019 19:48:01 -0400 Received: from Upsilon (mobile-166-171-185-104.mycingular.net [166.171.185.104]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x65Nlqi5009219 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 5 Jul 2019 23:47:53 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87r2799tzd.fsf@sdf.lonestar.org> <87d0isrsmk.fsf@sdf.lonestar.org> <878std3fw0.fsf@sdf.lonestar.org> <87wogwoqrg.fsf@gnu.org> <87bly8f3kq.fsf_-_@sdf.lonestar.org> <877e8wf3iz.fsf_-_@sdf.lonestar.org> Date: Fri, 05 Jul 2019 19:47:50 -0400 In-Reply-To: <877e8wf3iz.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:46:44 -0400") Message-ID: <8736jkf3h5.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: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services) (install-bootloader): Delete variable. * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure. --- gnu/machine/ssh.scm | 235 ++++++++++++-------------------------------- 1 file changed, 61 insertions(+), 174 deletions(-) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index a7d1a967a..72e6407f0 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -30,10 +30,13 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix remote) + #:use-module (guix scripts system) + #:use-module (guix scripts system reconfigure) #:use-module (guix ssh) #:use-module (guix store) #:use-module (ice-9 match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:export (managed-host-environment-type @@ -105,118 +108,6 @@ an environment type of 'managed-host." ;;; System deployment. ;;; -(define (switch-to-system machine) - "Monadic procedure creating a new generation on MACHINE and execute the -activation script for the new system configuration." - (define (remote-exp drv script) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((guix config) - (guix profiles) - (guix utils))) - #~(begin - (use-modules (guix config) - (guix profiles) - (guix utils)) - - (define %system-profile - (string-append %state-directory "/profiles/system")) - - (let* ((system #$drv) - (number (1+ (generation-number %system-profile))) - (generation (generation-file-name %system-profile number))) - (switch-symlinks generation system) - (switch-symlinks %system-profile generation) - ;; The implementation of 'guix system reconfigure' saves the - ;; load path and environment here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a distinct - ;; Guile REPL. - (setenv "GUIX_NEW_SYSTEM" system) - ;; The activation script may write to stdout, which confuses - ;; 'remote-eval' when it attempts to read a result from the - ;; remote REPL. We work around this by forcing the output to a - ;; string. - (with-output-to-string - (lambda () - (primitive-load #$script)))))))) - - (let* ((os (machine-system machine)) - (script (operating-system-activation-script os))) - (mlet* %store-monad ((drv (operating-system-derivation os))) - (machine-remote-eval machine (remote-exp drv script))))) - -;; XXX: Currently, this does NOT attempt to restart running services. This is -;; also the case with 'guix system reconfigure'. -;; -;; See . -(define (upgrade-shepherd-services machine) - "Monadic procedure unloading and starting services on the remote as needed -to realize the MACHINE's system configuration." - (define target-services - ;; Monadic expression evaluating to a list of (name output-path) pairs for - ;; all of MACHINE's services. - (mapm %store-monad - (lambda (service) - (mlet %store-monad ((file ((compose lower-object - shepherd-service-file) - service))) - (return (list (shepherd-service-canonical-name service) - (derivation->output-path file))))) - (service-value - (fold-services (operating-system-services (machine-system machine)) - #:target-type shepherd-root-service-type)))) - - (define (remote-exp target-services) - (with-imported-modules '((gnu services herd)) - #~(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (define running - (filter live-service-running (current-services))) - - (define (essential? service) - ;; Return #t if SERVICE is essential and should not be unloaded - ;; under any circumstance. - (memq (first (live-service-provision service)) - '(root shepherd))) - - (define (obsolete? service) - ;; Return #t if SERVICE can be safely unloaded. - (and (not (essential? service)) - (every (lambda (requirements) - (not (memq (first (live-service-provision service)) - requirements))) - (map live-service-requirement running)))) - - (define to-unload - (filter obsolete? - (remove (lambda (service) - (memq (first (live-service-provision service)) - (map first '#$target-services))) - running))) - - (define to-start - (remove (lambda (service-pair) - (memq (first service-pair) - (map (compose first live-service-provision) - running))) - '#$target-services)) - - ;; Unload obsolete services. - (for-each (lambda (service) - (false-if-exception - (unload-service service))) - to-unload) - - ;; Load the service files for any new services and start them. - (load-services/safe (map second to-start)) - (for-each start-service (map first to-start)) - - #t))) - - (mlet %store-monad ((target-services target-services)) - (machine-remote-eval machine (remote-exp target-services)))) - (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generations of MACHINE's system profile, ordered from most recent to oldest." @@ -275,71 +166,67 @@ of MACHINE's system profile, ordered from most recent to oldest." (boot-parameters-kernel-arguments params)))))))) generations)))) -(define (install-bootloader machine) - "Create a bootloader entry for the new system generation on MACHINE, and -configure the bootloader to boot that generation by default." - (define bootloader-installer-script - (@@ (guix scripts system) bootloader-installer-script)) - - (define (remote-exp installer bootcfg bootcfg-file) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((gnu build install) - (guix store) - (guix utils))) - #~(begin - (use-modules (gnu build install) - (guix store) - (guix utils)) - (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) - (temp-gc-root (string-append gc-root ".new"))) - - (switch-symlinks temp-gc-root gc-root) - - (unless (false-if-exception - (begin - ;; The implementation of 'guix system reconfigure' - ;; saves the load path here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a - ;; distinct Guile REPL. - (install-boot-config #$bootcfg #$bootcfg-file "/") - ;; The installation script may write to stdout, which - ;; confuses 'remote-eval' when it attempts to read a - ;; result from the remote REPL. We work around this - ;; by forcing the output to a string. - (with-output-to-string - (lambda () - (primitive-load #$installer))))) - (delete-file temp-gc-root) - (error "failed to install bootloader")) - - (rename-file temp-gc-root gc-root) - #t))))) - - (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) - (let* ((os (machine-system machine)) - (bootloader ((compose bootloader-configuration-bootloader - operating-system-bootloader) - os)) - (bootloader-target (bootloader-configuration-target - (operating-system-bootloader os))) - (installer (bootloader-installer-script - (bootloader-installer bootloader) - (bootloader-package bootloader) - bootloader-target - "/")) - (menu-entries (map boot-parameters->menu-entry boot-parameters)) - (bootcfg (operating-system-bootcfg os menu-entries)) - (bootcfg-file (bootloader-configuration-file bootloader))) - (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) - (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." - (maybe-raise-unsupported-configuration-error machine) - (mbegin %store-monad - (switch-to-system machine) - (upgrade-shepherd-services machine) - (install-bootloader machine))) + (define target-services + ;; Monadic expression evaluating to a list of + ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for the + ;; services in MACHINE's operating system configuration. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services (machine-system machine)) + #:target-type shepherd-root-service-type)))) + + (define (run-switch-to-system machine) + "Monadic procedure serializing the items in MACHINE necessary to build a +G-Expression with 'switch-to-system'." + (let* ((os (machine-system machine)) + (activation-script (operating-system-activation-script os))) + (mlet %store-monad ((osdrv (operating-system-derivation os))) + (machine-remote-eval machine + (switch-to-system osdrv activation-script))))) + + (define (run-upgrade-shepherd-services machine) + "Monadic procedure serializing the items in MACHINE necessary to build a +G-Expression with 'upgrade-shepherd-services'." + (mlet %store-monad ((target-services target-services)) + (machine-remote-eval machine + (upgrade-shepherd-services target-services)))) + + (define (run-install-bootloader machine) + "Monadic procedure serializing the items in MACHINE necessary to build a +G-Expression with 'install-bootloader'." + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (bootloader ((compose bootloader-configuration-bootloader + operating-system-bootloader) + os)) + (target (bootloader-configuration-target + (operating-system-bootloader os))) + (installer (bootloader-installer-script + (bootloader-installer bootloader) + (bootloader-package bootloader) + target + "/")) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootcfg (operating-system-bootcfg os menu-entries)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (machine-remote-eval machine + (install-bootloader installer bootcfg + bootcfg-file "/"))))) + + (maybe-raise-missing-configuration-error machine) + (mapm %store-monad (cut <> machine) + (list run-switch-to-system + run-upgrade-shepherd-services + run-install-bootloader))) ;;; From patchwork Fri Jul 5 23:48:36 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: 14485 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 35BCE171C0; Sat, 6 Jul 2019 00:49:13 +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 B179F171A5 for ; Sat, 6 Jul 2019 00:49:12 +0100 (BST) Received: from localhost ([::1]:57026 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXx2-0007gL-D1 for patchwork@mira.cbaines.net; Fri, 05 Jul 2019 19:49:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:42468) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXwv-0007fE-QN for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjXwu-0005qJ-4B for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:45173) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjXwu-0005qB-0z for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjXwt-0007fr-T0 for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 3/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: Fri, 05 Jul 2019 23:49:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36404 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156237052729468 (code B ref 36404); Fri, 05 Jul 2019 23:49:03 +0000 Received: (at 36404) by debbugs.gnu.org; 5 Jul 2019 23:48:47 +0000 Received: from localhost ([127.0.0.1]:53993 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXwc-0007fD-UO for submit@debbugs.gnu.org; Fri, 05 Jul 2019 19:48:47 -0400 Received: from mx.sdf.org ([205.166.94.20]:50745) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hjXwa-0007f5-Mz for 36404@debbugs.gnu.org; Fri, 05 Jul 2019 19:48:45 -0400 Received: from Upsilon (mobile-166-171-185-104.mycingular.net [166.171.185.104]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x65NmcvP003834 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 5 Jul 2019 23:48:39 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87r2799tzd.fsf@sdf.lonestar.org> <87d0isrsmk.fsf@sdf.lonestar.org> <878std3fw0.fsf@sdf.lonestar.org> <87wogwoqrg.fsf@gnu.org> <87bly8f3kq.fsf_-_@sdf.lonestar.org> <877e8wf3iz.fsf_-_@sdf.lonestar.org> <8736jkf3h5.fsf_-_@sdf.lonestar.org> Date: Fri, 05 Jul 2019 19:48:36 -0400 In-Reply-To: <8736jkf3h5.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:47:50 -0400") Message-ID: <87y31cdovf.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: 36404@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. * guix/scripts/system.scm (%switch-to-system) (%upgrade-shepherd-services, %install-bootloader): New variable. --- guix/scripts/system.scm | 161 +++++++++++++--------------------------- 1 file changed, 50 insertions(+), 111 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 21858ee7d..1f7912dcf 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)) @@ -179,38 +180,16 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer - #:key - bootcfg bootcfg-file - target) +(define (%install-bootloader installer 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)))) + (mlet* %store-monad ((file (lower-object + (scheme-file "install-bootloader.scm" + (install-bootloader installer bootcfg + bootcfg-file + target)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) (define* (install os-drv target #:key (log-port (current-output-port)) @@ -266,10 +245,8 @@ 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 bootloader-installer bootcfg + bootcfg-file target)))))) ;;; @@ -336,81 +313,47 @@ unload." (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) -(define (upgrade-shepherd-services os) +(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." + (define target-services + ;; Monadic expression evaluating to a list of + ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for the + ;; services in MACHINE's operating system configuration. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type)))) + + (mlet* %store-monad ((target-services target-services) + (file (lower-object + (scheme-file "upgrade-shepherd-services.scm" + (upgrade-shepherd-services + target-services)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) + +(define (%switch-to-system os) + "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)))) + (script (lower-object + (operating-system-activation-script os))) + (file (lower-object + (scheme-file "switch-to-system.scm" + (switch-to-system drv script)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -514,10 +457,7 @@ STORE is an open connection to the store." (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)))))) + (%install-bootloader #f bootcfg bootcfg-file target)))))) ;;; @@ -919,12 +859,11 @@ static checks." (case action ((reconfigure) (mbegin %store-monad - (switch-to-system os) + (%switch-to-system os) + (%upgrade-shepherd-services os) (mwhen install-bootloader? - (install-bootloader bootloader-script - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target "/")))) + (%install-bootloader bootloader-script bootcfg + bootcfg-file (or target "/"))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%")