From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:59542) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hoX81-0001Qy-1I for guix-patches@gnu.org; Fri, 19 Jul 2019 13:57:11 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hoX7w-0005NO-U6 for guix-patches@gnu.org; Fri, 19 Jul 2019 13:57:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:47706) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hoX7u-0005Mm-OV for guix-patches@gnu.org; Fri, 19 Jul 2019 13:57:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hoX7u-0001Gt-3M for guix-patches@gnu.org; Fri, 19 Jul 2019 13:57:02 -0400 Subject: [bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module. Resent-Message-ID: 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> <87y30v3qke.fsf@sdf.lonestar.org> <871rylrjt8.fsf_-_@sdf.lonestar.org> Date: Fri, 19 Jul 2019 13:55:58 -0400 In-Reply-To: <871rylrjt8.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 19 Jul 2019 13:54:59 -0400") Message-ID: <87wogdq575.fsf_-_@sdf.lonestar.org> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha256; protocol="application/pgp-signature" List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: Ludovic =?UTF-8?Q?Court=C3=A8s?= Cc: 36555@debbugs.gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable * 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. =2D-- Makefile.am | 1 + gnu/machine/ssh.scm | 189 ++-------------------- gnu/services/herd.scm | 6 + guix/scripts/system/reconfigure.scm | 241 ++++++++++++++++++++++++++++ tests/services.scm | 4 - 5 files changed, 260 insertions(+), 181 deletions(-) create mode 100644 guix/scripts/system/reconfigure.scm diff --git a/Makefile.am b/Makefile.am index dd7720e87..58a96d348 100644 =2D-- a/Makefile.am +++ b/Makefile.am @@ -245,6 +245,7 @@ MODULES =3D \ 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..64d92acc9 100644 =2D-- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -17,23 +17,21 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu machine ssh) =2D #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) =2D #:use-module (gnu services) =2D #:use-module (gnu services shepherd) #:use-module (gnu system) =2D #:use-module (guix derivations) #:use-module (guix gexp) #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix records) #:use-module (guix remote) + #: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 =20 @@ -105,118 +103,6 @@ an environment type of 'managed-host." ;;; System deployment. ;;; =20 =2D(define (switch-to-system machine) =2D "Monadic procedure creating a new generation on MACHINE and execute the =2Dactivation script for the new system configuration." =2D (define (remote-exp drv script) =2D (with-extensions (list guile-gcrypt) =2D (with-imported-modules (source-module-closure '((guix config) =2D (guix profiles) =2D (guix utils))) =2D #~(begin =2D (use-modules (guix config) =2D (guix profiles) =2D (guix utils)) =2D =2D (define %system-profile =2D (string-append %state-directory "/profiles/system")) =2D =2D (let* ((system #$drv) =2D (number (1+ (generation-number %system-profile))) =2D (generation (generation-file-name %system-profile num= ber))) =2D (switch-symlinks generation system) =2D (switch-symlinks %system-profile generation) =2D ;; The implementation of 'guix system reconfigure' saves t= he =2D ;; load path and environment here. This is unnecessary here =2D ;; because each invocation of 'remote-eval' runs in a dist= inct =2D ;; Guile REPL. =2D (setenv "GUIX_NEW_SYSTEM" system) =2D ;; The activation script may write to stdout, which confus= es =2D ;; 'remote-eval' when it attempts to read a result from the =2D ;; remote REPL. We work around this by forcing the output = to a =2D ;; string. =2D (with-output-to-string =2D (lambda () =2D (primitive-load #$script)))))))) =2D =2D (let* ((os (machine-system machine)) =2D (script (operating-system-activation-script os))) =2D (mlet* %store-monad ((drv (operating-system-derivation os))) =2D (machine-remote-eval machine (remote-exp drv script))))) =2D =2D;; XXX: Currently, this does NOT attempt to restart running services. Th= is is =2D;; also the case with 'guix system reconfigure'. =2D;; =2D;; See . =2D(define (upgrade-shepherd-services machine) =2D "Monadic procedure unloading and starting services on the remote as ne= eded =2Dto realize the MACHINE's system configuration." =2D (define target-services =2D ;; Monadic expression evaluating to a list of (name output-path) pai= rs for =2D ;; all of MACHINE's services. =2D (mapm %store-monad =2D (lambda (service) =2D (mlet %store-monad ((file ((compose lower-object =2D shepherd-service-file) =2D service))) =2D (return (list (shepherd-service-canonical-name service) =2D (derivation->output-path file))))) =2D (service-value =2D (fold-services (operating-system-services (machine-system mac= hine)) =2D #:target-type shepherd-root-service-type)))) =2D =2D (define (remote-exp target-services) =2D (with-imported-modules '((gnu services herd)) =2D #~(begin =2D (use-modules (gnu services herd) =2D (srfi srfi-1)) =2D =2D (define running =2D (filter live-service-running (current-services))) =2D =2D (define (essential? service) =2D ;; Return #t if SERVICE is essential and should not be unloa= ded =2D ;; under any circumstance. =2D (memq (first (live-service-provision service)) =2D '(root shepherd))) =2D =2D (define (obsolete? service) =2D ;; Return #t if SERVICE can be safely unloaded. =2D (and (not (essential? service)) =2D (every (lambda (requirements) =2D (not (memq (first (live-service-provision serv= ice)) =2D requirements))) =2D (map live-service-requirement running)))) =2D =2D (define to-unload =2D (filter obsolete? =2D (remove (lambda (service) =2D (memq (first (live-service-provision servi= ce)) =2D (map first '#$target-services))) =2D running))) =2D =2D (define to-start =2D (remove (lambda (service-pair) =2D (memq (first service-pair) =2D (map (compose first live-service-provision) =2D running))) =2D '#$target-services)) =2D =2D ;; Unload obsolete services. =2D (for-each (lambda (service) =2D (false-if-exception =2D (unload-service service))) =2D to-unload) =2D =2D ;; Load the service files for any new services and start them. =2D (load-services/safe (map second to-start)) =2D (for-each start-service (map first to-start)) =2D =2D #t))) =2D =2D (mlet %store-monad ((target-services target-services)) =2D (machine-remote-eval machine (remote-exp target-services)))) =2D (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generat= ions of MACHINE's system profile, ordered from most recent to oldest." @@ -275,71 +161,20 @@ of MACHINE's system profile, ordered from most recent= to oldest." (boot-parameters-kernel-arguments params)))))))) generations)))) =20 =2D(define (install-bootloader machine) =2D "Create a bootloader entry for the new system generation on MACHINE, a= nd =2Dconfigure the bootloader to boot that generation by default." =2D (define bootloader-installer-script =2D (@@ (guix scripts system) bootloader-installer-script)) =2D =2D (define (remote-exp installer bootcfg bootcfg-file) =2D (with-extensions (list guile-gcrypt) =2D (with-imported-modules (source-module-closure '((gnu build install) =2D (guix store) =2D (guix utils))) =2D #~(begin =2D (use-modules (gnu build install) =2D (guix store) =2D (guix utils)) =2D (let* ((gc-root (string-append "/" %gc-roots-directory "/boo= tcfg")) =2D (temp-gc-root (string-append gc-root ".new"))) =2D =2D (switch-symlinks temp-gc-root gc-root) =2D =2D (unless (false-if-exception =2D (begin =2D ;; The implementation of 'guix system reconfigu= re' =2D ;; saves the load path here. This is unnecessar= y here =2D ;; because each invocation of 'remote-eval' run= s in a =2D ;; distinct Guile REPL. =2D (install-boot-config #$bootcfg #$bootcfg-file "= /") =2D ;; The installation script may write to stdout,= which =2D ;; confuses 'remote-eval' when it attempts to r= ead a =2D ;; result from the remote REPL. We work around = this =2D ;; by forcing the output to a string. =2D (with-output-to-string =2D (lambda () =2D (primitive-load #$installer))))) =2D (delete-file temp-gc-root) =2D (error "failed to install bootloader")) =2D =2D (rename-file temp-gc-root gc-root) =2D #t))))) =2D =2D (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine= ))) =2D (let* ((os (machine-system machine)) =2D (bootloader ((compose bootloader-configuration-bootloader =2D operating-system-bootloader) =2D os)) =2D (bootloader-target (bootloader-configuration-target =2D (operating-system-bootloader os))) =2D (installer (bootloader-installer-script =2D (bootloader-installer bootloader) =2D (bootloader-package bootloader) =2D bootloader-target =2D "/")) =2D (menu-entries (map boot-parameters->menu-entry boot-parameter= s)) =2D (bootcfg (operating-system-bootcfg os menu-entries)) =2D (bootcfg-file (bootloader-configuration-file bootloader))) =2D (machine-remote-eval machine (remote-exp installer bootcfg bootcfg= -file))))) =2D (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with = an environment type of 'managed-host." (maybe-raise-unsupported-configuration-error machine) =2D (mbegin %store-monad =2D (switch-to-system machine) =2D (upgrade-shepherd-services machine) =2D (install-bootloader machine))) + (mlet %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (eval (cut machine-remote-eval machine <>)) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootloader-configuration (operating-system-bootloader os)) + (bootcfg (operating-system-bootcfg os menu-entries))) + (mbegin %store-monad + (switch-to-system eval os) + (upgrade-shepherd-services eval os) + (install-bootloader eval bootloader-configuration bootcfg))))) =20 ;;; diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 0008746fe..2207b2d34 100644 =2D-- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -40,10 +40,12 @@ unknown-shepherd-error? unknown-shepherd-error-sexp =20 + live-service live-service? live-service-provision live-service-requirement live-service-running + live-service-canonical-name =20 with-shepherd-action current-services @@ -192,6 +194,10 @@ of pairs." (requirement live-service-requirement) ;list of symbols (running live-service-running)) ;#f | object =20 +(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/reconfigure.scm b/guix/scripts/system/reco= nfigure.scm new file mode 100644 index 000000000..2c69ea727 =2D-- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,241 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Court=C3= =A8s +;;; Copyright =C2=A9 2016 Alex Kost +;;; Copyright =C2=A9 2016, 2017, 2018 Chris Marusich +;;; Copyright =C2=A9 2017 Mathieu Othacehe +;;; Copyright =C2=A9 2018 Ricardo Wurmus +;;; Copyright =C2=A9 2019 Christopher Baines +;;; Copyright =C2=A9 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 bootloader) + #:use-module (gnu services) + #:use-module (gnu services herd) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (switch-system-program + switch-to-system + + upgrade-services-program + upgrade-shepherd-services + + install-bootloader-program + install-bootloader)) + +;;; Commentary: +;;; +;;; This module implements the "effectful" parts of system +;;; reconfiguration. Although building a system derivation is a pure +;;; operation, a number of impure operations must be carried out for the +;;; system configuration to be realized -- chiefly, creation of generation +;;; symlinks and invocation of activation scripts. +;;; +;;; Code: + + +;;; +;;; Profile creation. +;;; + +(define* (switch-system-program os #:optional profile) + "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." + (program-file + "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/syst= em"))) + + (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) + (primitive-load #$(operating-system-activation-script os)))))= ))) + +(define* (switch-to-system eval os #:optional profile) + "Using EVAL, a monadic procedure taking a single G-Expression as an argu= ment, +create a new generation of PROFILE pointing to the directory of OS, switch= to +it atomically, and run OS's activation script." + (eval #~(primitive-load #$(switch-system-program os profile)))) + + +;;; +;;; Services. +;;; + +(define (running-services eval) + "Using EVAL, a monadic procedure taking a single G-Expression as an argu= ment, +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 necessa= rily + ;; serialize arbitrary objects. This should be fine for n= ow, + ;; since 'machine-current-services' is not exposed public= ly, + ;; 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 (eval remote-exp))) + (return (map (match-lambda + ((provision requirement) + (live-service provision requirement #f))) + services)))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; for details. +(define (upgrade-services-program service-files to-start to-unload to-rest= art) + "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)) + + ;; Load the service files for any new services. + (load-services/safe '#$service-files) + + ;; Unload obsolete services and start new services. + (for-each unload-service '#$to-unload) + (for-each start-service '#$to-start))))) + +(define* (upgrade-shepherd-services eval os) + "Using EVAL, a monadic procedure taking a single G-Expression as an argu= ment, +upgrade the Shepherd (PID 1) by unloading obsolete services and loading new +services as defined by OS." + (define target-services + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type))) + + (mlet* %store-monad ((live-services (running-services eval))) + (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-na= me + target-services) + (map live-service-canonical-name + live-services))) + (service-files + (map shepherd-service-file + (filter (lambda (service) + (memq (shepherd-service-canonical-name servic= e) + to-start)) + target-services)))) + (eval #~(primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))= ))) + + +;;; +;;; Bootloader configuration. +;;; + +;; (format (current-error-port) "error: ~a~%" (condition-message c)) +;; (format #t "bootloader successfully installed on '~a'~%" +;; #$device) + +(define (install-bootloader-program installer bootloader-package bootcfg + bootcfg-file device target) + "Return an executable store item that, upon being evaluated, will install +BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system devi= ce, +at TARGET, a mount point, and subsequently run INSTALLER from +BOOTLOADER-PACKAGE." + (program-file + "install-bootloader.scm" + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build bootloader) + (gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build bootloader) + (gnu build install) + (guix build utils) + (guix store) + (guix utils) + (ice-9 binary-ports) + (srfi srfi-34) + (srfi srfi-35)) + (let* ((gc-root (string-append #$target %gc-roots-directory "/b= ootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + (switch-symlinks temp-gc-root gc-root) + (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 w= ith + ;; a broken installation. + (when #$installer + (catch #t + (lambda () + (#$installer #$bootloader-package #$device #$target)) + (lambda args + (delete-file temp-gc-root) + (apply throw args)))) + (rename-file temp-gc-root gc-root))))))) + +(define* (install-bootloader eval configuration bootcfg + #:key + (run-installer? #t) + (target "/")) + "Using EVAL, a monadic procedure taking a single G-Expression as an argu= ment, +configure the bootloader on TARGET such that OS will be booted by default = and +additional configurations specified by MENU-ENTRIES can be selected." + (let* ((bootloader (bootloader-configuration-bootloader configuration)) + (installer (and run-installer? + (bootloader-installer bootloader))) + (package (bootloader-package bootloader)) + (device (bootloader-configuration-target configuration)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (eval #~(primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) diff --git a/tests/services.scm b/tests/services.scm index 44ad0022c..572fe3816 100644 =2D-- a/tests/services.scm +++ b/tests/services.scm @@ -26,10 +26,6 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match)) =20 =2D(define live-service =2D (@@ (gnu services herd) live-service)) =2D =2D (test-begin "services") =20 (test-equal "services, default value" =2D-=20 2.22.0 --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl0yBC4ACgkQ9Qb9Fp2P 2VqQtQ/9GtG7ubjhqPTZFIQRUkPgtOehl/uS2r68k2HJeuOHF1SBB4mNEJKTZc8g jz4ALx6d6D3XTeRmkaaV5FbzCq2BWnpeUD+Z1H3DUE+eUVPfCR6OV9UANTfMjvCb RdwNAXS2Z5cNslW1ztOtpaTNjeD+g0CY0goJVurI4q1arxImqWJQPpL4vZn9m2yD L6qI96bft/59fg7jVfsRuhFRemTdw1ROdZesq30bDQwAq/zR7N4gI+DMjW9QceZV bHxkno1jEsG5RK+ZWCeMHS+4PvXiabyk8LR6sNquaFsY9KxmraifTMbyn/pd6SDt Uh9/5Xzt4VuK/ngxF63x5fgfUtmuwtdufzm3xDoorWwQvUNgXChGhYhJPJQ8WcMA 2iS4tPi4tFGtNJiFSH6AN7MfohCXB5xlATNYPaipJ1YORt7MZ3goa9uFg8IPHCqc C9l7fvkH6CFTZUiQYD+gRlsxwN2a8G/Cw7IYwiWqVRaikm/rxsNhBidJAbn95C4E oqVX0rwB5dQduTK4UoSCmC3RyzuXWnkefN04xFnZ3veogmXD2R0UddF1ePSpQnj4 G++MqjOy1HoOhhMweS4W2VPpWl0gJroGOL//QFvoW619YtOXjLKH7W2DwwZ4HJ9J 6cYnSDRuOXM53Vu4qmlbPAxmGVpV9jraZCMd5FFGE2JlEC0Js6s= =d1I5 -----END PGP SIGNATURE----- --=-=-=--