From patchwork Tue Jul 9 19:08:11 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: 14551 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 18A3E171E8; Tue, 9 Jul 2019 20:26:26 +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 51EC4171E6 for ; Tue, 9 Jul 2019 20:26:25 +0100 (BST) Received: from localhost ([::1]:53750 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvku-0007S0-Nz for patchwork@mira.cbaines.net; Tue, 09 Jul 2019 15:26:24 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59120) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvUA-0002yw-Kt for guix-patches@gnu.org; Tue, 09 Jul 2019 15:09:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hkvU7-0003yx-SA for guix-patches@gnu.org; Tue, 09 Jul 2019 15:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:53687) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hkvU6-0003yA-HZ for guix-patches@gnu.org; Tue, 09 Jul 2019 15:09:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hkvU6-00047F-AP for guix-patches@gnu.org; Tue, 09 Jul 2019 15:09:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v2 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: Tue, 09 Jul 2019 19:09: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: Christopher Lemmer Webber Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156269930615775 (code B ref 36555); Tue, 09 Jul 2019 19:09:02 +0000 Received: (at 36555) by debbugs.gnu.org; 9 Jul 2019 19:08:26 +0000 Received: from localhost ([127.0.0.1]:34275 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvTQ-00046I-S6 for submit@debbugs.gnu.org; Tue, 09 Jul 2019 15:08:25 -0400 Received: from ol.sdf.org ([205.166.94.20]:58119 helo=mx.sdf.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvTO-00046A-Bu for 36555@debbugs.gnu.org; Tue, 09 Jul 2019 15:08:20 -0400 Received: from Upsilon (mobile-166-171-185-38.mycingular.net [166.171.185.38]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x69J8DEM029743 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 9 Jul 2019 19:08:15 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87imsbtk3o.fsf@dustycloud.org> <875zobvxg7.fsf_-_@sdf.lonestar.org> Date: Tue, 09 Jul 2019 15:08:11 -0400 In-Reply-To: <875zobvxg7.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 09 Jul 2019 15:07:20 -0400") Message-ID: <871ryzvxes.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/reconfigure.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/system.scm (bootloader-installer-script): Export variable. * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services) (install-bootloader): Delete variable. * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure. --- Makefile.am | 1 + gnu/machine/ssh.scm | 229 +++++++--------------------- guix/scripts/system.scm | 1 + guix/scripts/system/reconfigure.scm | 170 +++++++++++++++++++++ 4 files changed, 228 insertions(+), 173 deletions(-) create mode 100644 guix/scripts/system/reconfigure.scm diff --git a/Makefile.am b/Makefile.am index dd7720e87..58a96d348 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/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index a7d1a967a..5bac966ad 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,63 @@ 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." + (define target-services + (service-value + (fold-services (operating-system-services (machine-system machine)) + #:target-type shepherd-root-service-type))) + + (define (serialize-service service) + "Monadic procedure serializing SERVICE, a ." + (mlet %store-monad ((file (lower-object (shepherd-service-file service)))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + + (define (run-switch-to-system machine) + "Monadic procedure serializing the items in MACHINE necessary to build a +G-Expression with 'switch-to-system'." + (mlet %store-monad ((script (switch-system-program (machine-system machine)))) + (machine-remote-eval machine #~(primitive-load #$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 ((services (mapm %store-monad serialize-service + target-services)) + (script (upgrade-services-program services))) + (machine-remote-eval machine #~(primitive-load #$script)))) + + (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))) + (mlet %store-monad ((script (install-bootloader-program installer + bootcfg + bootcfg-file + "/"))) + (machine-remote-eval machine #~(primitive-load #$script)))))) + (maybe-raise-unsupported-configuration-error machine) - (mbegin %store-monad - (switch-to-system machine) - (upgrade-shepherd-services machine) - (install-bootloader machine))) + (mapm %store-monad (cut <> machine) + (list run-switch-to-system + run-upgrade-shepherd-services + run-install-bootloader))) ;;; 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..9491bde34 --- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,170 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2016 Alex Kost +;;; Copyright © 2016, 2017, 2018 Chris Marusich +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Christopher Baines +;;; 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 (gnu system) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (switch-system-program + upgrade-services-program + install-bootloader-program)) + +;;; 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-system-program os #:optional profile) + "Return as a monadic value a derivation to build a scheme file that, upon +being evaluated, will create a new generation of PROFILE pointing to the +directory of OS, switch to it atomically, and run OS's activation script, +returning any textual output produced by the activation script as a string." + (gexp->script + "switch-to-system.scm" + (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 profile + (or #$profile (string-append %state-directory "/profiles/system"))) + + (let* ((number (1+ (generation-number profile))) + (generation (generation-file-name profile number))) + (switch-symlinks generation #$os) + (switch-symlinks profile generation) + (setenv "GUIX_NEW_SYSTEM" #$os) + (with-output-to-string + (lambda () + (primitive-load + #$(operating-system-activation-script os)))))))))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; for details. +(define (upgrade-services-program target-services) + "Return as a monadic value a derivation to build a scheme file that, upon +being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete +services and loading new services. TARGET-SERVICES is a list +of (shepherd-service-canonical-name, shepherd-service-file) pairs used for +determining which services are obsolete, as well as which are new." + (gexp->script + "upgrade-shepherd-services.scm" + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (define (call-with-shepherd-error-handling proc) + (lambda (service) + (catch 'system-error + (lambda () + (proc service) + #f) + (lambda (key proc format-string format-args errno . rest) + (apply format #f format-string format-args))))) + + (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)) + + ;; Load the service files for any new services. + (load-services/safe (map second to-start)) + + ;; Unload obsolete services and start new services. + (filter string? + (append (map (call-with-shepherd-error-handling unload-service) + to-unload) + (map (call-with-shepherd-error-handling start-service) + (map first to-start)))))))) + +(define (install-bootloader-program installer-script bootcfg bootcfg-file target) + "Return as a monadic value a derivation to build a scheme file that, upon +being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on +TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any +textual output produced by the installer script as a string." + (gexp->script + "install-bootloader.scm" + (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 #$target %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + + (switch-symlinks temp-gc-root gc-root) + + (let ((installer-result + (false-if-exception + (begin + (install-boot-config #$bootcfg #$bootcfg-file #$target) + (with-output-to-string + (lambda () + (when #$installer-script + (primitive-load #$installer-script)))))))) + (unless installer-result + (delete-file temp-gc-root) + (error "failed to install bootloader")) + (rename-file temp-gc-root gc-root) + installer-result))))))) From patchwork Tue Jul 9 19:09:00 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: 14549 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 C1F17171E9; Tue, 9 Jul 2019 20:10:47 +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 31F4B171E6 for ; Tue, 9 Jul 2019 20:10:47 +0100 (BST) Received: from localhost ([::1]:53136 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvVm-0003tZ-NH for patchwork@mira.cbaines.net; Tue, 09 Jul 2019 15:10:46 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59561) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvV8-0003sD-FP for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hkvV6-0004R5-2o for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:53694) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hkvV4-0004Pe-78 for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hkvV4-00049D-1J for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v2 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: Tue, 09 Jul 2019 19:10:01 +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: Christopher Lemmer Webber Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156269934815858 (code B ref 36555); Tue, 09 Jul 2019 19:10:01 +0000 Received: (at 36555) by debbugs.gnu.org; 9 Jul 2019 19:09:08 +0000 Received: from localhost ([127.0.0.1]:34279 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvUC-00047i-2Y for submit@debbugs.gnu.org; Tue, 09 Jul 2019 15:09:08 -0400 Received: from ol.sdf.org ([205.166.94.20]:57869 helo=mx.sdf.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvUA-00047Z-QX for 36555@debbugs.gnu.org; Tue, 09 Jul 2019 15:09:07 -0400 Received: from Upsilon (mobile-166-171-185-38.mycingular.net [166.171.185.38]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x69J92WA002169 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 9 Jul 2019 19:09:03 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87imsbtk3o.fsf@dustycloud.org> <875zobvxg7.fsf_-_@sdf.lonestar.org> <871ryzvxes.fsf_-_@sdf.lonestar.org> Date: Tue, 09 Jul 2019 15:09:00 -0400 In-Reply-To: <871ryzvxes.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 09 Jul 2019 15:08:11 -0400") Message-ID: <87wogruisz.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. * guix/scripts/system.scm (%switch-to-system) (%upgrade-shepherd-services, %install-bootloader): New variable. --- guix/scripts/system.scm | 142 ++++++++++------------------------------ 1 file changed, 36 insertions(+), 106 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 21858ee7d..a1807c39c 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,14 @@ 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 ((script (install-bootloader-program installer bootcfg + bootcfg-file target)) + (file (lower-object script)) + (_ (built-derivations (list file)))) + (return (primitive-load (derivation->output-path file))))) (define* (install os-drv target #:key (log-port (current-output-port)) @@ -266,10 +243,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)))))) ;;; @@ -343,74 +318,31 @@ 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 + (define target-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 (serialize-service service) + "Monadic procedure serializing SERVICE, a ." + (mlet %store-monad ((file (lower-object (shepherd-service-file service)))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + + (mlet* %store-monad ((services (mapm %store-monad serialize-service + target-services)) + (script (upgrade-services-program services)) + (file (lower-object script)) + (_ (built-derivations (list file)))) + (return (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 ((script (switch-system-program os)) + (file (lower-object script)) + (_ (built-derivations (list file)))) + (return (primitive-load (derivation->output-path file))))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -514,10 +446,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)))))) ;;; @@ -918,13 +847,14 @@ static checks." (case action ((reconfigure) + (newline) + (format #t (G_ "activating system...~%")) (mbegin %store-monad (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'...~%") From patchwork Tue Jul 9 19:09:46 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: 14550 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 CB963171E8; Tue, 9 Jul 2019 20:11:00 +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 7BFF6171E6 for ; Tue, 9 Jul 2019 20:11:00 +0100 (BST) Received: from localhost ([::1]:53168 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvW0-0004C3-4o for patchwork@mira.cbaines.net; Tue, 09 Jul 2019 15:11:00 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59550) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hkvV8-0003rc-2f for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hkvV6-0004R1-3P for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:53695) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hkvV4-0004Pu-Q2 for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hkvV4-00049L-Jz for guix-patches@gnu.org; Tue, 09 Jul 2019 15:10:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v2 3/3] tests: Add reconfigure system test. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 09 Jul 2019 19:10: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: Christopher Lemmer Webber Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156269939415925 (code B ref 36555); Tue, 09 Jul 2019 19:10:02 +0000 Received: (at 36555) by debbugs.gnu.org; 9 Jul 2019 19:09:54 +0000 Received: from localhost ([127.0.0.1]:34282 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvUv-00048n-ML for submit@debbugs.gnu.org; Tue, 09 Jul 2019 15:09:54 -0400 Received: from ol.sdf.org ([205.166.94.20]:57648 helo=mx.sdf.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hkvUu-00048f-1U for 36555@debbugs.gnu.org; Tue, 09 Jul 2019 15:09:52 -0400 Received: from Upsilon (mobile-166-171-185-38.mycingular.net [166.171.185.38]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x69J9l72015496 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 9 Jul 2019 19:09:50 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87imsbtk3o.fsf@dustycloud.org> <875zobvxg7.fsf_-_@sdf.lonestar.org> <871ryzvxes.fsf_-_@sdf.lonestar.org> <87wogruisz.fsf_-_@sdf.lonestar.org> Date: Tue, 09 Jul 2019 15:09:46 -0400 In-Reply-To: <87wogruisz.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 09 Jul 2019 15:09:00 -0400") Message-ID: <87sgrfuirp.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 * gnu/tests/reconfigure.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/local.mk | 1 + gnu/tests/reconfigure.scm | 99 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 100 insertions(+) create mode 100644 gnu/tests/reconfigure.scm diff --git a/gnu/local.mk b/gnu/local.mk index 0e17af953..b334d0572 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -592,6 +592,7 @@ GNU_SYSTEM_MODULES = \ %D%/tests/mail.scm \ %D%/tests/messaging.scm \ %D%/tests/networking.scm \ + %D%/tests/reconfigure.scm \ %D%/tests/rsync.scm \ %D%/tests/security-token.scm \ %D%/tests/singularity.scm \ diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm new file mode 100644 index 000000000..bb8c33bf5 --- /dev/null +++ b/gnu/tests/reconfigure.scm @@ -0,0 +1,99 @@ +;;; 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 (gnu tests reconfigure) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (gnu services) + #:use-module (gnu services networking) + #:use-module (gnu services shepherd) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix scripts system reconfigure) + #:use-module (guix store) + #:export (%test-switch-to-system)) + +;;; Commentary: +;;; +;;; Test in-place system reconfiguration: advancing the system generation on a +;;; running instance of the Guix System. +;;; +;;; Code: + +(define* (run-switch-to-system-test) + "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new +generation of the system profile." + (define os + (marionette-operating-system + (simple-operating-system) + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm (virtual-machine os)) + + (define (test script) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64)) + + (define marionette + (make-marionette (list #$vm))) + + (define (system-generations marionette) + "Return the names of the generation symlinks on MARIONETTE." + (marionette-eval + '(begin + (use-modules (ice-9 ftw) + (srfi srfi-1)) + (let* ((profile-dir "/var/guix/profiles/") + (entries (map first (cddr (file-system-tree profile-dir))))) + (remove (lambda (entry) + (member entry '("per-user" "system"))) + entries))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "switch-to-system") + + (let ((generations-prior (system-generations marionette))) + (test-assert "capture activation script output" + (string? + (marionette-eval + '(primitive-load #$script) + marionette))) + + (test-equal "deployment created new generation" + (length (system-generations marionette)) + (1+ (length generations-prior)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (mlet %store-monad ((script (switch-system-program os))) + (gexp->derivation "switch-to-system" (test script)))) + +(define %test-switch-to-system + (system-test + (name "switch-to-system") + (description "Create a new generation of the system profile.") + (value (run-switch-to-system-test))))