From patchwork Tue Jul 16 23:47:18 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: 14700 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 A01A617233; Wed, 17 Jul 2019 00:48:15 +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 9D29017232 for ; Wed, 17 Jul 2019 00:48:14 +0100 (BST) Received: from localhost ([::1]:52950 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXB8-0005CF-Ar for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:48:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:37279) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXAz-0004uy-SD for guix-patches@gnu.org; Tue, 16 Jul 2019 19:48:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnXAx-0006dl-15 for guix-patches@gnu.org; Tue, 16 Jul 2019 19:48:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42521) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnXAw-0006de-T9 for guix-patches@gnu.org; Tue, 16 Jul 2019 19:48:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnXAw-00043U-Rs for guix-patches@gnu.org; Tue, 16 Jul 2019 19:48:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v3 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, 16 Jul 2019 23:48: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: 36555@debbugs.gnu.org Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156332085615528 (code B ref 36555); Tue, 16 Jul 2019 23:48:02 +0000 Received: (at 36555) by debbugs.gnu.org; 16 Jul 2019 23:47:36 +0000 Received: from localhost ([127.0.0.1]:51336 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXAQ-00042I-RM for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:47:35 -0400 Received: from mx.sdf.org ([205.166.94.20]:54579) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXAN-000424-Lo for 36555@debbugs.gnu.org; Tue, 16 Jul 2019 19:47:29 -0400 Received: from Upsilon (mobile-107-107-59-57.mycingular.net [107.107.59.57]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x6GNlMSk008403 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 16 Jul 2019 23:47:25 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87ef30i9fl.fsf@sdf.lonestar.org> <87y3129qsn.fsf@gnu.org> <87sgr9bziq.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> Date: Tue, 16 Jul 2019 19:47:18 -0400 In-Reply-To: <87v9w1zgon.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 16 Jul 2019 19:46:16 -0400") Message-ID: <87r26pzgmx.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: , 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. * gnu/services/herd.scm (live-service): Export variable. * gnu/services/herd.scm (live-service-canonical-name): New variable. * tests/services.scm (live-service): Delete variable. --- Makefile.am | 1 + gnu/machine/ssh.scm | 266 ++++++++++------------------ gnu/services/herd.scm | 6 + guix/scripts/system.scm | 1 + guix/scripts/system/reconfigure.scm | 170 ++++++++++++++++++ tests/services.scm | 4 - 6 files changed, 272 insertions(+), 176 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..a5c5c6b39 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,6 +21,7 @@ #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu services) + #:use-module (gnu services herd) #:use-module (gnu services shepherd) #:use-module (gnu system) #:use-module (guix derivations) @@ -30,10 +31,15 @@ #: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-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:export (managed-host-environment-type @@ -105,118 +111,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 +169,99 @@ 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 (machine-current-services machine) + "Return the objects that are currently running on MACHINE." + (define remote-exp + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd)) + (let ((services (current-services))) + (and services + ;; 'live-service-running' is ignored, as we can't necessarily + ;; serialize arbitrary objects. This should be fine for now, + ;; since 'machine-current-services' is not exposed publicly, + ;; and the resultant objects are only used for + ;; resolving service dependencies. + (map (lambda (service) + (list (live-service-provision service) + (live-service-requirement service))) + services)))))) + (mlet %store-monad ((services (machine-remote-eval machine remote-exp))) + (return (map (match-lambda + ((provision requirement) + (live-service provision requirement #f))) + services)))) (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 (run-switch-to-system machine) + "Monadic procedure serializing the items in MACHINE necessary to build a +G-Expression with 'switch-to-system'." + (machine-remote-eval machine #~(primitive-load + #$(switch-system-program + (machine-system machine))))) + + (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 ((live-services (machine-current-services machine))) + (let-values (((to-unload to-restart) + (shepherd-service-upgrade live-services target-services))) + (let* ((to-unload (map live-service-canonical-name to-unload)) + (to-restart (map shepherd-service-canonical-name to-restart)) + (to-start (lset-difference + eqv? + (map shepherd-service-canonical-name target-services) + (map live-service-canonical-name live-services))) + (service-files + (map shepherd-service-file + (filter (lambda (service) + (memq (shepherd-service-canonical-name service) + to-start)) + target-services)))) + (machine-remote-eval machine + #~(primitive-load + #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) + + (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 + #~(primitive-load + #$(install-bootloader-program installer + bootcfg + bootcfg-file + "/")))))) + (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-install-bootloader + run-upgrade-shepherd-services))) ;;; diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 0008746fe..2207b2d34 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -40,10 +40,12 @@ unknown-shepherd-error? unknown-shepherd-error-sexp + live-service live-service? live-service-provision live-service-requirement live-service-running + live-service-canonical-name with-shepherd-action current-services @@ -192,6 +194,10 @@ of pairs." (requirement live-service-requirement) ;list of symbols (running live-service-running)) ;#f | object +(define (live-service-canonical-name service) + "Return the 'canonical name' of SERVICE." + (first (live-service-provision service))) + (define (current-services) "Return the list of currently defined Shepherd services, represented as objects. Return #f if the list of services could not be 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))))))) diff --git a/tests/services.scm b/tests/services.scm index 44ad0022c..572fe3816 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -26,10 +26,6 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match)) -(define live-service - (@@ (gnu services herd) live-service)) - - (test-begin "services") (test-equal "services, default value" From patchwork Tue Jul 16 23:48:09 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: 14701 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 9583D17232; Wed, 17 Jul 2019 00:49: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 EF79417232 for ; Wed, 17 Jul 2019 00:49:08 +0100 (BST) Received: from localhost ([::1]:52954 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXC0-0005pB-M7 for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:49:08 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:37589) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXBw-0005oq-QF for guix-patches@gnu.org; Tue, 16 Jul 2019 19:49:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnXBu-0007Dg-Kg for guix-patches@gnu.org; Tue, 16 Jul 2019 19:49:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42527) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnXBu-0007DZ-HE for guix-patches@gnu.org; Tue, 16 Jul 2019 19:49:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnXBu-00045P-Di for guix-patches@gnu.org; Tue, 16 Jul 2019 19:49:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v3 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, 16 Jul 2019 23:49: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: 36555@debbugs.gnu.org Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156332090015656 (code B ref 36555); Tue, 16 Jul 2019 23:49:02 +0000 Received: (at 36555) by debbugs.gnu.org; 16 Jul 2019 23:48:20 +0000 Received: from localhost ([127.0.0.1]:51348 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXBD-00044R-C0 for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:48:20 -0400 Received: from mx.sdf.org ([205.166.94.20]:54395) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXBA-00044H-17 for 36555@debbugs.gnu.org; Tue, 16 Jul 2019 19:48:17 -0400 Received: from Upsilon (mobile-107-107-59-57.mycingular.net [107.107.59.57]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x6GNmAje022067 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 16 Jul 2019 23:48:13 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87ef30i9fl.fsf@sdf.lonestar.org> <87y3129qsn.fsf@gnu.org> <87sgr9bziq.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> <87r26pzgmx.fsf_-_@sdf.lonestar.org> Date: Tue, 16 Jul 2019 19:48:09 -0400 In-Reply-To: <87r26pzgmx.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 16 Jul 2019 19:47:18 -0400") Message-ID: <87muhdzgli.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: , 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 | 151 +++++++++------------------- guix/scripts/system/reconfigure.scm | 116 +++++++-------------- 2 files changed, 79 insertions(+), 188 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 21858ee7d..b59818577 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 ((file (lower-object + (install-bootloader-program installer bootcfg + bootcfg-file target))) + (_ (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,39 @@ 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)))) + (let-values (((to-unload to-restart) + (shepherd-service-upgrade (current-services) target-services))) + (let* ((to-unload (map live-service-canonical-name to-unload)) + (to-restart (map shepherd-service-canonical-name to-restart)) + (to-start (lset-difference + eqv? + (map shepherd-service-canonical-name target-services) + (map live-service-canonical-name (current-services)))) + (service-files + (map shepherd-service-file + (filter (lambda (service) + (memq (shepherd-service-canonical-name service) + to-start)) + target-services)))) + (mlet* %store-monad ((file (lower-object + (upgrade-services-program service-files + to-start + to-unload + to-restart))) + (_ (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 ((file (lower-object (switch-system-program os))) + (_ (built-derivations (list file)))) + (return (primitive-load (derivation->output-path file))))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -514,10 +454,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 +855,15 @@ static checks." (case action ((reconfigure) + (newline) + (format #t (G_ "activating system...~%")) (mbegin %store-monad (switch-to-system os) (mwhen install-bootloader? - (install-bootloader bootloader-script - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target "/")))) + (install-bootloader bootloader-script bootcfg + bootcfg-file (or target "/"))) + (with-shepherd-error-handling + (upgrade-shepherd-services os)))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 9491bde34..1ef656f0c 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -42,11 +42,11 @@ ;;; 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 + "Return an executable store item 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." + (program-file "switch-to-system.scm" (with-extensions (list guile-gcrypt) (with-imported-modules (source-module-closure '((guix config) @@ -65,82 +65,36 @@ returning any textual output produced by the activation script as a string." (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)))))))))) + (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 +(define (upgrade-services-program service-files to-start to-unload to-restart) + "Return an executable store item that, upon being evaluated, will upgrade +the Shepherd (PID 1) by unloading obsolete services and loading new +services. SERVICE-FILES is a list of Shepherd service files to load, and +TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services' +canonical names (symbols)." + (program-file "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)) + (load-services/safe '#$service-files) ;; 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)))))))) + (for-each unload-service '#$to-unload) + (for-each start-service '#$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 + "Return an executable store item 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." + (program-file "install-bootloader.scm" (with-extensions (list guile-gcrypt) (with-imported-modules (source-module-closure '((gnu build install) @@ -152,19 +106,17 @@ textual output produced by the installer script as a string." (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))))))) + (install-boot-config #$bootcfg #$bootcfg-file #$target) + ;; Preserve the previous activation's garbage collector root + ;; until the bootloader installer has run, so that a failure in + ;; the bootloader's installer script doesn't leave the user with + ;; a broken installation. + (when #$installer-script + (catch #t + (lambda () + (primitive-load #$installer-script)) + (lambda args + (delete-file temp-gc-root) + (apply throw args)))) + (rename-file temp-gc-root gc-root))))))) From patchwork Tue Jul 16 23:48:57 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: 14702 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 2001C17233; Wed, 17 Jul 2019 00:50: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 0FA8A17232 for ; Wed, 17 Jul 2019 00:50:08 +0100 (BST) Received: from localhost ([::1]:52956 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXCx-0006Ln-Ob for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:50:07 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:37911) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnXCt-0006BW-SB for guix-patches@gnu.org; Tue, 16 Jul 2019 19:50:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnXCr-0007ts-TP for guix-patches@gnu.org; Tue, 16 Jul 2019 19:50:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42531) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnXCr-0007tk-QE for guix-patches@gnu.org; Tue, 16 Jul 2019 19:50:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnXCr-00047D-OE for guix-patches@gnu.org; Tue, 16 Jul 2019 19:50:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36555] [PATCH v3 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, 16 Jul 2019 23:50: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: 36555@debbugs.gnu.org Received: via spool by 36555-submit@debbugs.gnu.org id=B36555.156332095015756 (code B ref 36555); Tue, 16 Jul 2019 23:50:01 +0000 Received: (at 36555) by debbugs.gnu.org; 16 Jul 2019 23:49:10 +0000 Received: from localhost ([127.0.0.1]:51352 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXC1-000463-8u for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:49:09 -0400 Received: from mx.sdf.org ([205.166.94.20]:54162) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnXBy-00045u-U4 for 36555@debbugs.gnu.org; Tue, 16 Jul 2019 19:49:07 -0400 Received: from Upsilon (mobile-107-107-59-57.mycingular.net [107.107.59.57]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x6GNn1lR029387 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 16 Jul 2019 23:49:03 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87imsci9sj.fsf@sdf.lonestar.org> <87ef30i9fl.fsf@sdf.lonestar.org> <87y3129qsn.fsf@gnu.org> <87sgr9bziq.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> <87r26pzgmx.fsf_-_@sdf.lonestar.org> <87muhdzgli.fsf_-_@sdf.lonestar.org> Date: Tue, 16 Jul 2019 19:48:57 -0400 In-Reply-To: <87muhdzgli.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 16 Jul 2019 19:48:09 -0400") Message-ID: <87ims1zgk6.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: , 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 | 268 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 269 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..251e96b3e --- /dev/null +++ b/gnu/tests/reconfigure.scm @@ -0,0 +1,268 @@ +;;; 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 bootloader) + #:use-module (gnu services networking) + #:use-module (gnu services shepherd) + #:use-module (gnu services) + #:use-module (gnu system vm) + #:use-module (gnu system) + #:use-module (gnu tests) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix scripts system) + #:use-module (guix scripts system reconfigure) + #:use-module (guix store) + #:export (%test-switch-to-system + %test-upgrade-services + %test-install-bootloader)) + +;;; 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 "script successfully evaluated" + (marionette-eval + '(primitive-load #$script) + marionette)) + + (test-equal "script created new generation" + (length (system-generations marionette)) + (1+ (length generations-prior)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "switch-to-system" (test (switch-system-program os)))) + +(define* (run-upgrade-services-test) + "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the +Shepherd (PID 1) by unloading obsolete services and loading new services." + (define os + (marionette-operating-system + (simple-operating-system) + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm (virtual-machine os)) + + (define dummy-service + ;; Shepherd service that does nothing, for the sole purpose of ensuring + ;; that it is properly installed and started by the script. + (shepherd-service (provision '(dummy)) + (start #~(const #t)) + (stop #~(const #t)) + (respawn? #f))) + + (define (ensure-service-file service) + "Return the Shepherd service file for SERVICE, after ensuring that it +exists in the store" + (let ((file (shepherd-service-file service))) + (mlet* %store-monad ((store-object (lower-object file)) + (_ (built-derivations (list store-object)))) + (return file)))) + + (define (test enable-dummy disable-dummy) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64)) + + (define marionette + (make-marionette (list #$vm))) + + (define (running-services marionette) + "Return the names of the running services on MARIONETTE." + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (map live-service-canonical-name (current-services))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "upgrade-services") + + (let ((services-prior (running-services marionette))) + (test-assert "script successfully evaluated" + (marionette-eval + '(primitive-load #$enable-dummy) + marionette)) + + (test-assert "script started new service" + (and (not (memq 'dummy services-prior)) + (memq 'dummy (running-services marionette)))) + + (test-assert "script successfully evaluated" + (marionette-eval + '(primitive-load #$disable-dummy) + marionette)) + + (test-assert "script stopped new service" + (not (memq 'dummy (running-services marionette))))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (mlet* %store-monad ((file (ensure-service-file dummy-service))) + (let ((enable (upgrade-services-program (list file) '(dummy) '() '())) + (disable (upgrade-services-program '() '() '(dummy) '()))) + (gexp->derivation "upgrade-services" (test enable disable))))) + +(define* (run-install-bootloader-test) + "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a +bootloader's configuration file." + (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) + (ice-9 regex) + (srfi srfi-1) + (srfi srfi-64)) + + (define marionette + (make-marionette (list #$vm))) + + (define (generations-in-grub-cfg marionette) + "Return the system generation paths that have GRUB menu entries." + (let ((grub-cfg (marionette-eval + '(begin + (call-with-input-file "/boot/grub/grub.cfg" + (lambda (port) + (get-string-all port)))) + marionette))) + (map (lambda (parameter) + (second (string-split (match:substring parameter) #\=))) + (list-matches "system=[^ ]*" grub-cfg)))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "install-bootloader") + + + (test-assert "no prior menu entry for system generation" + (not (member #$os (generations-in-grub-cfg marionette)))) + + (test-assert "script successfully evaluated" + (marionette-eval + '(primitive-load #$script) + marionette)) + + (test-assert "menu entry created for system generation" + (member #$os (generations-in-grub-cfg marionette))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (let* ((bootloader ((compose bootloader-configuration-bootloader + operating-system-bootloader) + os)) + (target (bootloader-configuration-target + (operating-system-bootloader os))) + ;; The typical use-case for 'install-bootloader-program' is to read + ;; the boot parameters for the existing menu entries on the system, + ;; parse them with 'boot-parameters->menu-entry', and pass the + ;; results to 'operating-system-bootcfg'. However, to obtain boot + ;; parameters, we would need to start the marionette, which we should + ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we + ;; generate a bootloader configuration for the script as if there + ;; were no existing menu entries. In the grand scheme of things, this + ;; matters little -- these tests should not make assertions about the + ;; behavior of 'operating-system-bootcfg'. + (bootcfg (operating-system-bootcfg os '())) + (bootcfg-file (bootloader-configuration-file bootloader))) + (gexp->derivation + "install-bootloader" + ;; Due to the read-only nature of the virtual machines used in the system + ;; test suite, the bootloader installer script is omitted. 'grub-install' + ;; would attempt to write directly to the virtual disk if the + ;; installation script were run. + (test (install-bootloader-program #f bootcfg bootcfg-file "/"))))) + +(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)))) + +(define %test-upgrade-services + (system-test + (name "upgrade-services") + (description "Upgrade the Shepherd by unloading obsolete services and +loading new services.") + (value (run-upgrade-services-test)))) + +(define %test-install-bootloader + (system-test + (name "install-bootloader") + (description "Install a bootloader and its configuration file.") + (value (run-install-bootloader-test))))