From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:42465) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXwv-0007fD-DA for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjXwt-0005px-Ic for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:45172) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjXwt-0005pq-Fn for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjXwr-0007fi-UB for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 Subject: [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. Resent-Message-ID: From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87r2799tzd.fsf@sdf.lonestar.org> <87d0isrsmk.fsf@sdf.lonestar.org> <878std3fw0.fsf@sdf.lonestar.org> <87wogwoqrg.fsf@gnu.org> <87bly8f3kq.fsf_-_@sdf.lonestar.org> <877e8wf3iz.fsf_-_@sdf.lonestar.org> Date: Fri, 05 Jul 2019 19:47:50 -0400 In-Reply-To: <877e8wf3iz.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:46:44 -0400") Message-ID: <8736jkf3h5.fsf_-_@sdf.lonestar.org> 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: 36404@debbugs.gnu.org --=-=-= Content-Type: text/plain Content-Transfer-Encoding: quoted-printable * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services) (install-bootloader): Delete variable. * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure. =2D-- gnu/machine/ssh.scm | 235 ++++++++++++-------------------------------- 1 file changed, 61 insertions(+), 174 deletions(-) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index a7d1a967a..72e6407f0 100644 =2D-- 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 =20 @@ -105,118 +108,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 +166,67 @@ 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." =2D (maybe-raise-unsupported-configuration-error machine) =2D (mbegin %store-monad =2D (switch-to-system machine) =2D (upgrade-shepherd-services machine) =2D (install-bootloader machine))) + (define target-services + ;; Monadic expression evaluating to a list of + ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for = the + ;; services in MACHINE's operating system configuration. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services (machine-system machi= ne)) + #:target-type shepherd-root-service-type)))) + + (define (run-switch-to-system machine) + "Monadic procedure serializing the items in MACHINE necessary to build= a +G-Expression with 'switch-to-system'." + (let* ((os (machine-system machine)) + (activation-script (operating-system-activation-script os))) + (mlet %store-monad ((osdrv (operating-system-derivation os))) + (machine-remote-eval machine + (switch-to-system osdrv activation-script))))) + + (define (run-upgrade-shepherd-services machine) + "Monadic procedure serializing the items in MACHINE necessary to build= a +G-Expression with 'upgrade-shepherd-services'." + (mlet %store-monad ((target-services target-services)) + (machine-remote-eval machine + (upgrade-shepherd-services target-services)))) + + (define (run-install-bootloader machine) + "Monadic procedure serializing the items in MACHINE necessary to build= a +G-Expression with 'install-bootloader'." + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine= ))) + (let* ((os (machine-system machine)) + (bootloader ((compose bootloader-configuration-bootloader + operating-system-bootloader) + os)) + (target (bootloader-configuration-target + (operating-system-bootloader os))) + (installer (bootloader-installer-script + (bootloader-installer bootloader) + (bootloader-package bootloader) + target + "/")) + (menu-entries (map boot-parameters->menu-entry boot-parameter= s)) + (bootcfg (operating-system-bootcfg os menu-entries)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (machine-remote-eval machine + (install-bootloader installer bootcfg + bootcfg-file "/"))))) + + (maybe-raise-missing-configuration-error machine) + (mapm %store-monad (cut <> machine) + (list run-switch-to-system + run-upgrade-shepherd-services + run-install-bootloader))) =20 ;;; =2D-=20 2.22.0 --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl0f4aYACgkQ9Qb9Fp2P 2VrYWA//afYfK0/aUJtB4LRbWzlK9a2I8/h0Lr77OumWev39qWNf3dgrI53DfoJ8 k1rnOshpaZPzKXhGg5XYQRxUhQiUOrB3WVwsdiuZlKxIqyldOd2+w13ndAhaBVky 2WopOjJ9Poh54G1ccmWfwucKx2oMwKq5JdfkXcOcswhKteo6yZRY7TZV7zNpf3n7 uulHzq0fdZs1BRJIwo/VdtCe4N+ngzLmhLyTAjX2ef7BcpcKTXraI2IcHtLpcf2p vqODAenlJg8GkODQ0gphSdjmkP6Hf4u8+fDY92dI+9XUAQGLVnjb74vOwI0X/YH7 7gt8Csldn+gAYoCDpJqVa8Ug6Vb0O6GFp7aVpgKoUYtvjH92D296tjsvPScPeOv2 gDxDqXp+WnRb5TkVZqn6rKJyLQEHQ6vDzr0sfhNAUbEaJghasNgjyIxljlYCGHoS b0YG5shD0f+sll9tR+h5Nvok2FbTrJgwm3yxzANT3PlQDrZBm8on9Occl2DGmFoF 1TlGcuh5VLprCDXWXEV0K8eBFyG+aifsOdMNVubRa+GjFMUOnVZ7JCY2WZe2YH3H d1vFBlQtRgCujoUM5lChFFSsxixcsz9mjDJzuwj0IoZ8nuY8vuO7URd1K0LHMQFB V8yEJZkDdhZLtL/SCBF04kA/ZKnOVWnvD9rR+8zNEZclWwuHAOs= =/LPw -----END PGP SIGNATURE----- --=-=-=--