all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze)
To: "Ludovic Courtès" <ludo@gnu.org>
Cc: 36404@debbugs.gnu.org
Subject: [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment.
Date: Fri, 05 Jul 2019 19:47:50 -0400	[thread overview]
Message-ID: <8736jkf3h5.fsf_-_@sdf.lonestar.org> (raw)
In-Reply-To: <877e8wf3iz.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:46:44 -0400")

[-- Attachment #1: Type: text/plain, Size: 12958 bytes --]

* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
---
 gnu/machine/ssh.scm | 235 ++++++++++++--------------------------------
 1 file changed, 61 insertions(+), 174 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..72e6407f0 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -30,10 +30,13 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix remote)
+  #:use-module (guix scripts system)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
   #:export (managed-host-environment-type
 
@@ -105,118 +108,6 @@ an environment type of 'managed-host."
 ;;; System deployment.
 ;;;
 
-(define (switch-to-system machine)
-  "Monadic procedure creating a new generation on MACHINE and execute the
-activation script for the new system configuration."
-  (define (remote-exp drv script)
-    (with-extensions (list guile-gcrypt)
-      (with-imported-modules (source-module-closure '((guix config)
-                                                      (guix profiles)
-                                                      (guix utils)))
-        #~(begin
-            (use-modules (guix config)
-                         (guix profiles)
-                         (guix utils))
-
-            (define %system-profile
-              (string-append %state-directory "/profiles/system"))
-
-            (let* ((system #$drv)
-                   (number (1+ (generation-number %system-profile)))
-                   (generation (generation-file-name %system-profile number)))
-              (switch-symlinks generation system)
-              (switch-symlinks %system-profile generation)
-              ;; The implementation of 'guix system reconfigure' saves the
-              ;; load path and environment here. This is unnecessary here
-              ;; because each invocation of 'remote-eval' runs in a distinct
-              ;; Guile REPL.
-              (setenv "GUIX_NEW_SYSTEM" system)
-              ;; The activation script may write to stdout, which confuses
-              ;; 'remote-eval' when it attempts to read a result from the
-              ;; remote REPL. We work around this by forcing the output to a
-              ;; string.
-              (with-output-to-string
-                (lambda ()
-                  (primitive-load #$script))))))))
-
-  (let* ((os (machine-system machine))
-         (script (operating-system-activation-script os)))
-    (mlet* %store-monad ((drv (operating-system-derivation os)))
-      (machine-remote-eval machine (remote-exp drv script)))))
-
-;; XXX: Currently, this does NOT attempt to restart running services. This is
-;; also the case with 'guix system reconfigure'.
-;;
-;; See <https://issues.guix.info/issue/33508>.
-(define (upgrade-shepherd-services machine)
-  "Monadic procedure unloading and starting services on the remote as needed
-to realize the MACHINE's system configuration."
-  (define target-services
-    ;; Monadic expression evaluating to a list of (name output-path) pairs for
-    ;; all of MACHINE's services.
-    (mapm %store-monad
-          (lambda (service)
-            (mlet %store-monad ((file ((compose lower-object
-                                                shepherd-service-file)
-                                       service)))
-              (return (list (shepherd-service-canonical-name service)
-                            (derivation->output-path file)))))
-          (service-value
-           (fold-services (operating-system-services (machine-system machine))
-                          #:target-type shepherd-root-service-type))))
-
-  (define (remote-exp target-services)
-    (with-imported-modules '((gnu services herd))
-      #~(begin
-          (use-modules (gnu services herd)
-                       (srfi srfi-1))
-
-          (define running
-            (filter live-service-running (current-services)))
-
-          (define (essential? service)
-            ;; Return #t if SERVICE is essential and should not be unloaded
-            ;; under any circumstance.
-            (memq (first (live-service-provision service))
-                  '(root shepherd)))
-
-          (define (obsolete? service)
-            ;; Return #t if SERVICE can be safely unloaded.
-            (and (not (essential? service))
-                 (every (lambda (requirements)
-                          (not (memq (first (live-service-provision service))
-                                     requirements)))
-                        (map live-service-requirement running))))
-
-          (define to-unload
-            (filter obsolete?
-                    (remove (lambda (service)
-                              (memq (first (live-service-provision service))
-                                    (map first '#$target-services)))
-                            running)))
-
-          (define to-start
-            (remove (lambda (service-pair)
-                      (memq (first service-pair)
-                            (map (compose first live-service-provision)
-                                 running)))
-                    '#$target-services))
-
-          ;; Unload obsolete services.
-          (for-each (lambda (service)
-                      (false-if-exception
-                       (unload-service service)))
-                    to-unload)
-
-          ;; Load the service files for any new services and start them.
-          (load-services/safe (map second to-start))
-          (for-each start-service (map first to-start))
-
-          #t)))
-
-  (mlet %store-monad ((target-services target-services))
-    (machine-remote-eval machine (remote-exp target-services))))
-
 (define (machine-boot-parameters machine)
   "Monadic procedure returning a list of 'boot-parameters' for the generations
 of MACHINE's system profile, ordered from most recent to oldest."
@@ -275,71 +166,67 @@ of MACHINE's system profile, ordered from most recent to oldest."
                            (boot-parameters-kernel-arguments params))))))))
           generations))))
 
-(define (install-bootloader machine)
-  "Create a bootloader entry for the new system generation on MACHINE, and
-configure the bootloader to boot that generation by default."
-  (define bootloader-installer-script
-    (@@ (guix scripts system) bootloader-installer-script))
-
-  (define (remote-exp installer bootcfg bootcfg-file)
-    (with-extensions (list guile-gcrypt)
-      (with-imported-modules (source-module-closure '((gnu build install)
-                                                      (guix store)
-                                                      (guix utils)))
-        #~(begin
-            (use-modules (gnu build install)
-                         (guix store)
-                         (guix utils))
-            (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
-                   (temp-gc-root (string-append gc-root ".new")))
-
-              (switch-symlinks temp-gc-root gc-root)
-
-              (unless (false-if-exception
-                       (begin
-                         ;; The implementation of 'guix system reconfigure'
-                         ;; saves the load path here. This is unnecessary here
-                         ;; because each invocation of 'remote-eval' runs in a
-                         ;; distinct Guile REPL.
-                         (install-boot-config #$bootcfg #$bootcfg-file "/")
-                         ;; The installation script may write to stdout, which
-                         ;; confuses 'remote-eval' when it attempts to read a
-                         ;; result from the remote REPL. We work around this
-                         ;; by forcing the output to a string.
-                         (with-output-to-string
-                           (lambda ()
-                             (primitive-load #$installer)))))
-                (delete-file temp-gc-root)
-                (error "failed to install bootloader"))
-
-              (rename-file temp-gc-root gc-root)
-              #t)))))
-
-  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
-    (let* ((os (machine-system machine))
-           (bootloader ((compose bootloader-configuration-bootloader
-                                 operating-system-bootloader)
-                        os))
-           (bootloader-target (bootloader-configuration-target
-                               (operating-system-bootloader os)))
-           (installer (bootloader-installer-script
-                       (bootloader-installer bootloader)
-                       (bootloader-package bootloader)
-                       bootloader-target
-                       "/"))
-           (menu-entries (map boot-parameters->menu-entry boot-parameters))
-           (bootcfg (operating-system-bootcfg os menu-entries))
-           (bootcfg-file (bootloader-configuration-file bootloader)))
-      (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
-
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
-  (maybe-raise-unsupported-configuration-error machine)
-  (mbegin %store-monad
-    (switch-to-system machine)
-    (upgrade-shepherd-services machine)
-    (install-bootloader machine)))
+  (define target-services
+    ;; Monadic expression evaluating to a list of
+    ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for the
+    ;; services in MACHINE's operating system configuration.
+    (mapm %store-monad
+          (lambda (service)
+            (mlet %store-monad ((file ((compose lower-object
+                                                shepherd-service-file)
+                                       service)))
+              (return (list (shepherd-service-canonical-name service)
+                            (derivation->output-path file)))))
+          (service-value
+           (fold-services (operating-system-services (machine-system machine))
+                          #:target-type shepherd-root-service-type))))
+
+  (define (run-switch-to-system machine)
+    "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'switch-to-system'."
+    (let* ((os (machine-system machine))
+           (activation-script (operating-system-activation-script os)))
+      (mlet %store-monad ((osdrv (operating-system-derivation os)))
+        (machine-remote-eval machine
+                             (switch-to-system osdrv activation-script)))))
+
+  (define (run-upgrade-shepherd-services machine)
+    "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'upgrade-shepherd-services'."
+    (mlet %store-monad ((target-services target-services))
+      (machine-remote-eval machine
+                           (upgrade-shepherd-services target-services))))
+
+  (define (run-install-bootloader machine)
+    "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'install-bootloader'."
+    (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
+      (let* ((os (machine-system machine))
+             (bootloader ((compose bootloader-configuration-bootloader
+                                   operating-system-bootloader)
+                          os))
+             (target (bootloader-configuration-target
+                      (operating-system-bootloader os)))
+             (installer (bootloader-installer-script
+                         (bootloader-installer bootloader)
+                         (bootloader-package bootloader)
+                         target
+                         "/"))
+             (menu-entries (map boot-parameters->menu-entry boot-parameters))
+             (bootcfg (operating-system-bootcfg os menu-entries))
+             (bootcfg-file (bootloader-configuration-file bootloader)))
+        (machine-remote-eval machine
+                             (install-bootloader installer bootcfg
+                                                 bootcfg-file "/")))))
+
+  (maybe-raise-missing-configuration-error machine)
+  (mapm %store-monad (cut <> machine)
+        (list run-switch-to-system
+              run-upgrade-shepherd-services
+              run-install-bootloader)))
 
 \f
 ;;;
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

  reply	other threads:[~2019-07-05 23:49 UTC|newest]

Thread overview: 84+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2019-06-27 18:35 [bug#36404] [PATCH 0/6] Add 'guix deploy' Jakob L. Kreuze
2019-06-27 18:38 ` [bug#36404] [PATCH 1/6] Take another stab at this whole guix deploy thing Jakob L. Kreuze
2019-06-27 18:39   ` [bug#36404] [PATCH 2/6] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze
2019-06-27 18:40     ` [bug#36404] [PATCH 3/6] gnu: Add machine type for deployment specifications Jakob L. Kreuze
2019-06-27 18:40       ` [bug#36404] [PATCH 4/6] Export the (gnu machine) interface Jakob L. Kreuze
2019-06-27 18:41         ` [bug#36404] [PATCH 5/6] Add 'guix deploy' Jakob L. Kreuze
2019-06-27 18:42           ` [bug#36404] [PATCH 6/6] doc: Add section for " Jakob L. Kreuze
2019-06-29 21:43             ` Christopher Lemmer Webber
2019-06-30  0:35               ` Jakob L. Kreuze
2019-06-29 21:38           ` [bug#36404] [PATCH 5/6] Add " Christopher Lemmer Webber
2019-06-29 21:36         ` [bug#36404] [PATCH 4/6] Export the (gnu machine) interface Christopher Lemmer Webber
2019-06-29 22:04         ` Ricardo Wurmus
2019-06-30  0:41           ` Jakob L. Kreuze
2019-06-27 20:05 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Thompson, David
2019-06-28 13:34   ` [bug#36404] [PATCH 0/5] " Jakob L. Kreuze
2019-06-28 13:35     ` [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze
2019-06-28 13:35       ` [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications Jakob L. Kreuze
2019-06-28 13:36         ` [bug#36404] [PATCH 3/5] Add 'guix deploy' Jakob L. Kreuze
2019-06-28 13:37           ` [bug#36404] [PATCH 4/5] Export the (gnu machine) interface Jakob L. Kreuze
2019-06-28 13:37             ` [bug#36404] [PATCH 5/5] doc: Add section for 'guix deploy' Jakob L. Kreuze
2019-06-29 21:36         ` [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications Christopher Lemmer Webber
2019-06-30  0:30           ` Jakob L. Kreuze
2019-06-30  4:58             ` Carlo Zancanaro
2019-06-30 12:34               ` Christopher Lemmer Webber
2019-07-01 23:51                 ` Jakob L. Kreuze
2019-07-04 12:48                   ` Christopher Lemmer Webber
2019-07-04 16:05                     ` Jakob L. Kreuze
2019-06-30 12:28             ` Christopher Lemmer Webber
2019-07-02  0:03               ` Jakob L. Kreuze
2019-06-29 14:42       ` [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session' Christopher Lemmer Webber
2019-06-29 23:45         ` Jakob L. Kreuze
2019-06-29 14:37 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Christopher Lemmer Webber
2019-06-29 23:42   ` Jakob L. Kreuze
2019-07-01 12:50     ` Ludovic Courtès
2019-07-01 10:09   ` Ricardo Wurmus
2019-07-01 12:53   ` Ludovic Courtès
2019-07-02  0:10     ` Jakob L. Kreuze
2019-07-02 22:14       ` Jakob L. Kreuze
2019-07-04 16:48         ` Jakob L. Kreuze
2019-07-05  8:00           ` Ludovic Courtès
2019-07-05 23:45             ` [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-05 23:46               ` [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-05 23:47                 ` Jakob L. Kreuze [this message]
2019-07-05 23:48                   ` [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-06 22:20                     ` Ludovic Courtès
2019-07-06 22:13                   ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Ludovic Courtès
2019-07-07  7:13                   ` Christopher Lemmer Webber
2019-07-07 13:05                     ` Ludovic Courtès
2019-07-06 22:11                 ` [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module Ludovic Courtès
2019-07-06 22:02               ` [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration Ludovic Courtès
2019-07-07  7:02               ` Christopher Lemmer Webber
2019-07-07 13:06                 ` Ludovic Courtès
2019-07-08 19:22                   ` Jakob L. Kreuze
2019-07-02  0:14     ` [bug#36404] [PATCH 0/4] Add 'guix deploy' Jakob L. Kreuze
2019-07-02  0:16       ` [bug#36404] [PATCH 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze
2019-07-02  0:17         ` [bug#36404] [PATCH 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze
2019-07-02  0:17           ` [bug#36404] [PATCH 3/4] Add 'guix deploy' Jakob L. Kreuze
2019-07-02  0:18             ` [bug#36404] [PATCH 4/4] doc: Add section for " Jakob L. Kreuze
     [not found]               ` <875zoldqah.fsf@kyleam.com>
     [not found]                 ` <87muhwtmfp.fsf@sdf.lonestar.org>
     [not found]                   ` <871rz874l2.fsf@kyleam.com>
     [not found]                     ` <877e90tj7l.fsf_-_@sdf.lonestar.org>
2019-07-02 17:56                       ` [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze
2019-07-02 17:56                         ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze
2019-07-02 17:57                           ` [bug#36404] [PATCH v4 3/4] Add 'guix deploy' Jakob L. Kreuze
2019-07-02 17:58                             ` [bug#36404] [PATCH v4 4/4] doc: Add section for " Jakob L. Kreuze
2019-07-03 23:07                               ` Christopher Lemmer Webber
2019-07-04  9:20                                 ` Ludovic Courtès
2019-07-05  1:39                               ` Thompson, David
2019-07-05  8:29                               ` Ludovic Courtès
2019-07-05  1:35                             ` [bug#36404] [PATCH v4 3/4] Add " Thompson, David
2019-07-05  8:17                             ` Ludovic Courtès
2019-07-04  9:19                           ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Ludovic Courtès
2019-07-04 15:59                             ` Jakob L. Kreuze
2019-07-05  1:32                           ` Thompson, David
2019-07-05  8:10                             ` Ludovic Courtès
2019-07-05  8:24                           ` Ludovic Courtès
2019-07-05 18:53                             ` [bug#36404] [PATCH v5 0/4] Add 'guix deploy' Jakob L. Kreuze
2019-07-05 18:54                               ` [bug#36404] [PATCH v5 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze
2019-07-05 18:55                                 ` [bug#36404] [PATCH v5 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze
2019-07-05 18:56                                   ` [bug#36404] [PATCH v5 3/4] Add 'guix deploy' Jakob L. Kreuze
2019-07-05 18:57                                     ` [bug#36404] [PATCH v5 4/4] doc: Add section for " Jakob L. Kreuze
2019-07-06  6:14                                       ` bug#36404: " Christopher Lemmer Webber
2019-07-05 23:25                                         ` [bug#36404] " Jakob L. Kreuze
2019-07-06 21:50                                         ` Ludovic Courtès
2019-07-05  1:23                         ` [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Thompson, David
2019-07-01 12:48 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Ludovic Courtès
2019-07-05 10:32 ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Christopher Lemmer Webber

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=8736jkf3h5.fsf_-_@sdf.lonestar.org \
    --to=zerodaysfordays@sdf.lonestar.org \
    --cc=36404@debbugs.gnu.org \
    --cc=ludo@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.